├── .gitignore ├── LICENSE.txt ├── Makefile ├── README.txt ├── asdf.lisp ├── doc └── client-info.txt ├── quicklisp ├── bundle-template.lisp ├── bundle.lisp ├── cdb.lisp ├── client-info.lisp ├── client-update.lisp ├── client.lisp ├── config.lisp ├── deflate.lisp ├── dist-update.lisp ├── dist.lisp ├── fetch-gzipped.lisp ├── http.lisp ├── impl-util.lisp ├── impl.lisp ├── local-projects.lisp ├── minitar.lisp ├── misc.lisp ├── network.lisp ├── package.lisp ├── progress.lisp ├── quicklisp.asd ├── setup.lisp ├── utils.lisp └── version.txt └── setup.lisp /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *~ 3 | quicklisp.tar 4 | quicklisp.tar.gz 5 | asdf.lisp.* 6 | cache 7 | client-info.sexp 8 | dists 9 | local-projects 10 | retired 11 | tmp 12 | -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Zachary Beane 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 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: gzip 2 | git archive --format=tar version-`cat quicklisp/version.txt` quicklisp/ > quicklisp.tar 3 | gzip -fnk9 quicklisp.tar 4 | 5 | gzip: 6 | gzip -fnk9 setup.lisp asdf.lisp 7 | 8 | clean: 9 | rm -f quicklisp.tar quicklisp.tar.gz setup.lisp.gz asdf.lisp.gz 10 | 11 | tag: 12 | test -z "`git status -s quicklisp/ asdf.lisp setup.lisp`" 13 | git tag version-`cat quicklisp/version.txt` 14 | -------------------------------------------------------------------------------- /README.txt: -------------------------------------------------------------------------------- 1 | This is the client portion of Quicklisp. It is responsible for 2 | downloading and managing project metadata, downloading and installing 3 | project releases, loading system files, and performing code, data, and 4 | metadata updates. 5 | 6 | For more information about the Quicklisp client, please see: 7 | 8 | http://www.quicklisp.org/beta/ 9 | 10 | For more information about Quicklisp, please see: 11 | 12 | http://www.quicklisp.org/ 13 | 14 | If you have questions or comments about this project, please email 15 | Zach Beane . 16 | 17 | 18 | Portions of this client (deflate.lisp) are derived from Pierre Mai's 19 | Deflate library, which is licensed under the following terms: 20 | 21 | Deflate --- RFC 1951 Deflate Decompression 22 | 23 | Copyright (C) 2000-2009 PMSF IT Consulting Pierre R. Mai. 24 | 25 | Permission is hereby granted, free of charge, to any person obtaining 26 | a copy of this software and associated documentation files (the 27 | "Software"), to deal in the Software without restriction, including 28 | without limitation the rights to use, copy, modify, merge, publish, 29 | distribute, sublicense, and/or sell copies of the Software, and to 30 | permit persons to whom the Software is furnished to do so, subject to 31 | the following conditions: 32 | 33 | The above copyright notice and this permission notice shall be 34 | included in all copies or substantial portions of the Software. 35 | 36 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 37 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 38 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 39 | IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR 40 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 41 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 42 | OTHER DEALINGS IN THE SOFTWARE. 43 | 44 | Except as contained in this notice, the name of the author shall 45 | not be used in advertising or otherwise to promote the sale, use or 46 | other dealings in this Software without prior written authorization 47 | from the author. 48 | 49 | 50 | -------------------------------------------------------------------------------- /doc/client-info.txt: -------------------------------------------------------------------------------- 1 | The client-info file format is a simple s-expression plist that is 2 | read with *READ-EVAL* set to nil. 3 | 4 | There should be the following keys and values: 5 | 6 | :VERSION - a string representing the version of the 7 | client. Traditionally this is an ISO8601 date string. 8 | 9 | :CLIENT-INFO-FORMAT - a string representing the version of the 10 | client-info file format. Currently this is "1". When the file format 11 | is updated it will change. 12 | 13 | Three remaining keys use the client-info-file plist format. That 14 | format has the following keys and values: 15 | 16 | :URL - an URL string to use for fetching the file 17 | 18 | :SIZE - an integer representing the size in octets of the file 19 | 20 | :md5 - a string representing the hexadecimal MD5 digest of the file 21 | 22 | :sha256 - a string representing the hexadecimal SHA256 digetst of 23 | the file 24 | 25 | There remaining three keys are as follows: 26 | 27 | :CLIENT-TAR - a client-info-file plist for the tarball containing 28 | the Quicklisp client code 29 | 30 | :SETUP - a client-info-file plist for the setup.lisp file that is 31 | loaded when starting Quicklisp 32 | 33 | :ASDF - a client-info-file plist for asdf.lisp 34 | 35 | A file with a plist of this structure can be loaded with 36 | LOAD-CLIENT-INFO to produce a CLIENT-INFO instance. See 37 | client-info.lisp and client-update.lisp for more information. 38 | -------------------------------------------------------------------------------- /quicklisp/bundle-template.lisp: -------------------------------------------------------------------------------- 1 | (cl:in-package #:cl-user) 2 | 3 | (eval-when (:compile-toplevel :load-toplevel :execute) 4 | (require "asdf") 5 | (unless (find-package '#:asdf) 6 | (error "ASDF could not be required"))) 7 | 8 | (let ((indicator '#:ql-bundle-v1) 9 | (searcher-name '#:ql-bundle-searcher) 10 | (base (make-pathname :name nil :type nil 11 | :defaults #. (or *compile-file-truename* 12 | *load-truename*)))) 13 | (labels ((file-lines (file) 14 | (with-open-file (stream file) 15 | (loop for line = (read-line stream nil) 16 | while line 17 | collect line))) 18 | (relative (pathname) 19 | (merge-pathnames pathname base)) 20 | (pathname-timestamp (pathname) 21 | #+clisp 22 | (nth-value 2 (ext:probe-pathname pathname)) 23 | #-clisp 24 | (file-write-date pathname)) 25 | (system-table (table pathnames) 26 | (dolist (pathname pathnames table) 27 | (setf (gethash (pathname-name pathname) table) 28 | (relative pathname)))) 29 | 30 | (initialize-bundled-systems-table (table data-source) 31 | (system-table table 32 | (mapcar (lambda (line) 33 | (merge-pathnames line data-source)) 34 | (file-lines data-source)))) 35 | 36 | (local-projects-system-pathnames (data-source) 37 | (let ((files (directory (merge-pathnames "**/*.asd" 38 | data-source)))) 39 | (stable-sort (sort files #'string< :key #'namestring) 40 | #'< 41 | :key (lambda (file) 42 | (length (namestring file)))))) 43 | (initialize-local-projects-table (table data-source) 44 | (system-table table (local-projects-system-pathnames data-source))) 45 | 46 | (make-table (&key data-source init-function) 47 | (let ((table (make-hash-table :test 'equalp))) 48 | (setf (gethash "/data-source" table) 49 | data-source 50 | (gethash "/timestamp" table) 51 | (pathname-timestamp data-source) 52 | (gethash "/init" table) 53 | init-function) 54 | table)) 55 | 56 | (tcall (table key &rest args) 57 | (let ((fun (gethash key table))) 58 | (unless (and fun (functionp fun)) 59 | (error "Unknown function key ~S" key)) 60 | (apply fun args))) 61 | (created-timestamp (table) 62 | (gethash "/timestamp" table)) 63 | (data-source-timestamp (table) 64 | (pathname-timestamp (data-source table))) 65 | (data-source (table) 66 | (gethash "/data-source" table)) 67 | 68 | (stalep (table) 69 | ;; FIXME: Handle newly missing data sources? 70 | (< (created-timestamp table) 71 | (data-source-timestamp table))) 72 | (meta-key-p (key) 73 | (and (stringp key) 74 | (< 0 (length key)) 75 | (char= (char key 0) #\/))) 76 | (clear (table) 77 | ;; Don't clear "/foo" keys 78 | (maphash (lambda (key value) 79 | (declare (ignore value)) 80 | (unless (meta-key-p key) 81 | (remhash key table))) 82 | table)) 83 | (initialize (table) 84 | (tcall table "/init" table (data-source table)) 85 | (setf (gethash "/timestamp" table) 86 | (pathname-timestamp (data-source table))) 87 | table) 88 | (update (table) 89 | (clear table) 90 | (initialize table)) 91 | (lookup (system-name table) 92 | (when (stalep table) 93 | (update table)) 94 | (values (gethash system-name table))) 95 | 96 | (search-function (system-name) 97 | (let ((tables (get searcher-name indicator))) 98 | (dolist (table tables) 99 | (let* ((result (lookup system-name table)) 100 | (probed (and result (probe-file result)))) 101 | (when probed 102 | (return probed)))))) 103 | 104 | (make-bundled-systems-table () 105 | (initialize 106 | (make-table :data-source (relative "system-index.txt") 107 | :init-function #'initialize-bundled-systems-table))) 108 | (make-bundled-local-projects-systems-table () 109 | (let ((data-source (relative "bundled-local-projects/system-index.txt"))) 110 | (when (probe-file data-source) 111 | (initialize 112 | (make-table :data-source data-source 113 | :init-function #'initialize-bundled-systems-table))))) 114 | (make-local-projects-table () 115 | (initialize 116 | (make-table :data-source (relative "local-projects/") 117 | :init-function #'initialize-local-projects-table))) 118 | 119 | (=matching-data-sources (tables) 120 | (let ((data-sources (mapcar #'data-source tables))) 121 | (lambda (table) 122 | (member (data-source table) data-sources 123 | :test #'equalp)))) 124 | 125 | (check-for-existing-searcher (searchers) 126 | (block done 127 | (dolist (searcher searchers) 128 | (when (symbolp searcher) 129 | (let ((plist (symbol-plist searcher))) 130 | (loop for key in plist by #'cddr 131 | when 132 | (and (symbolp key) (string= key indicator)) 133 | do 134 | (setf indicator key) 135 | (setf searcher-name searcher) 136 | (return-from done t))))))) 137 | 138 | (clear-asdf (table) 139 | (maphash (lambda (system-name pathname) 140 | (declare (ignore pathname)) 141 | (asdf:clear-system system-name)) 142 | table))) 143 | 144 | (let ((existing (check-for-existing-searcher 145 | asdf:*system-definition-search-functions*))) 146 | (let* ((local (make-local-projects-table)) 147 | (bundled-local-projects 148 | (make-bundled-local-projects-systems-table)) 149 | (bundled (make-bundled-systems-table)) 150 | (new-tables (remove nil (list local 151 | bundled-local-projects 152 | bundled))) 153 | (existing-tables (get searcher-name indicator)) 154 | (filter (=matching-data-sources new-tables))) 155 | (setf (get searcher-name indicator) 156 | (append new-tables (delete-if filter existing-tables))) 157 | (map nil #'clear-asdf new-tables)) 158 | (unless existing 159 | (setf (symbol-function searcher-name) #'search-function) 160 | (push searcher-name asdf:*system-definition-search-functions*))) 161 | t)) 162 | -------------------------------------------------------------------------------- /quicklisp/bundle.lisp: -------------------------------------------------------------------------------- 1 | ;;;; bundle.lisp 2 | 3 | (in-package #:ql-bundle) 4 | 5 | ;;; Bundling is taking a set of Quicklisp-provided systems and 6 | ;;; creating a directory structure and metadata in which those systems 7 | ;;; can be loaded without involving Quicklisp. 8 | ;;; 9 | ;;; This works for systems provided directly Quicklisp, or systems in 10 | ;;; the Quicklisp local-projects directories (if 11 | ;;; :include-local-projects is specified). 12 | 13 | (defgeneric find-system (system bundle)) 14 | (defgeneric add-system (system bundle)) 15 | (defgeneric ensure-system (system bundle)) 16 | 17 | (defgeneric find-release (relase bundle)) 18 | (defgeneric add-release (release bundle)) 19 | (defgeneric ensure-release (release bundle)) 20 | 21 | (defgeneric write-loader-script (bundle stream)) 22 | (defgeneric write-system-index (bundle stream)) 23 | 24 | (defgeneric unpack-release (release target)) 25 | (defgeneric unpack-releases (bundle target)) 26 | 27 | (defgeneric write-bundle (bundle target)) 28 | 29 | (defvar *ignored-systems* 30 | (list "asdf") 31 | "Systems that might appear in depends-on lists in Quicklisp, but 32 | which can't be bundled.") 33 | 34 | (defvar *bundle-progress-output* 35 | (make-synonym-stream '*trace-output*) 36 | "Informative output related to creating the bundle is sent to this 37 | stream.") 38 | 39 | ;;; Implementation 40 | 41 | ;;; Conditions 42 | 43 | (define-condition bundle-error (error) ()) 44 | 45 | (define-condition object-not-found (bundle-error) 46 | ((name 47 | :initarg :name 48 | :reader object-not-found-name) 49 | (type 50 | :initarg :type 51 | :reader object-not-found-type)) 52 | (:report 53 | (lambda (condition stream) 54 | (format stream "~A ~S not found" 55 | (object-not-found-type condition) 56 | (object-not-found-name condition)))) 57 | (:default-initargs 58 | :type "Object")) 59 | 60 | (define-condition system-not-found (object-not-found) 61 | ((name 62 | :reader system-not-found-system)) 63 | (:default-initargs 64 | :type "System")) 65 | 66 | (define-condition release-not-found (object-not-found) 67 | () 68 | (:default-initargs 69 | :type "Release")) 70 | 71 | (define-condition bundle-directory-exists (bundle-error) 72 | ((directory 73 | :initarg :directory 74 | :reader bundle-directory-exists-directory)) 75 | (:report 76 | (lambda (condition stream) 77 | (format stream "Bundle directory ~A already exists" 78 | (bundle-directory-exists-directory condition))))) 79 | 80 | 81 | (defun iso8601-time-stamp (&optional (time (get-universal-time))) 82 | (multiple-value-bind (second minute hour day month year) 83 | (decode-universal-time time 0) 84 | (format nil "~4,'0D-~2,'0D-~2,'0DT~ 85 | ~2,'0D:~2,'0D:~2,'0DZ" 86 | year month day 87 | hour minute second))) 88 | 89 | 90 | (defclass bundle () 91 | ((requested-systems 92 | :initarg :requested-systems 93 | :reader requested-systems 94 | :documentation "Names of the systems requested directly for 95 | bundling.") 96 | (creation-time 97 | :initarg :creation-time 98 | :reader creation-time) 99 | (release-table 100 | :initarg :release-table 101 | :reader release-table) 102 | (system-table 103 | :initarg :system-table 104 | :reader system-table)) 105 | (:default-initargs 106 | :requested-systems nil 107 | :creation-time (iso8601-time-stamp) 108 | :release-table (make-hash-table :test 'equalp) 109 | :system-table (make-hash-table :test 'equalp))) 110 | 111 | (defmethod print-object ((bundle bundle) stream) 112 | (print-unreadable-object (bundle stream :type t) 113 | (format stream "~D release~:P, ~D system~:P" 114 | (hash-table-count (release-table bundle)) 115 | (hash-table-count (system-table bundle))))) 116 | 117 | (defmethod provided-releases ((bundle bundle)) 118 | (let ((releases '())) 119 | (maphash (lambda (name release) 120 | (declare (ignore name)) 121 | (push release releases)) 122 | (release-table bundle)) 123 | (sort releases 'string< :key 'name))) 124 | 125 | (defmethod provided-systems ((bundle bundle)) 126 | (sort (mapcan #'provided-systems (provided-releases bundle)) 127 | 'string< 128 | :key 'name)) 129 | 130 | (defmethod find-system (name (bundle bundle)) 131 | (values (gethash name (system-table bundle)))) 132 | 133 | (defmethod add-system (name (bundle bundle)) 134 | (let ((system (ql-dist:find-system name))) 135 | (unless system 136 | (error 'system-not-found 137 | :name name)) 138 | (ensure-release (name (release system)) bundle) 139 | system)) 140 | 141 | (defmethod ensure-system (name (bundle bundle)) 142 | (or (find-system name bundle) 143 | (add-system name bundle))) 144 | 145 | (defmethod find-release (name (bundle bundle)) 146 | (values (gethash name (release-table bundle)))) 147 | 148 | (defmethod add-release (name (bundle bundle)) 149 | (let ((release (ql-dist:find-release name))) 150 | (unless release 151 | (error 'release-not-found 152 | :name name)) 153 | (setf (gethash (name release) (release-table bundle)) release) 154 | (let ((system-table (system-table bundle))) 155 | (dolist (system (provided-systems release)) 156 | (setf (gethash (name system) system-table) system))) 157 | release)) 158 | 159 | (defmethod ensure-release (name (bundle bundle)) 160 | (or (find-release name bundle) 161 | (add-release name bundle))) 162 | 163 | 164 | (defun add-systems-recursively (names bundle) 165 | (with-consistent-dists 166 | (labels ((add-one (name) 167 | (unless (member name *ignored-systems* :test 'equalp) 168 | (let ((system 169 | (restart-case 170 | (ensure-system name bundle) 171 | (omit () 172 | :report "Ignore this system and omit it from the bundle.")))) 173 | (when system 174 | (dolist (required-system-name (required-systems system)) 175 | (add-one required-system-name))))))) 176 | (map nil #'add-one names))) 177 | bundle) 178 | 179 | 180 | (defmethod unpack-release (release target) 181 | (let ((*default-pathname-defaults* (truename 182 | (ensure-directories-exist target))) 183 | (archive (ensure-local-archive-file release)) 184 | (temp-tar (ensure-directories-exist 185 | (ql-setup:qmerge "tmp/bundle.tar")))) 186 | (ql-gunzipper:gunzip archive temp-tar) 187 | (ql-minitar:unpack-tarball temp-tar :directory "software/") 188 | (delete-file temp-tar) 189 | release)) 190 | 191 | (defmethod unpack-releases ((bundle bundle) target) 192 | (dolist (release (provided-releases bundle)) 193 | (unpack-release release target)) 194 | bundle) 195 | 196 | (defmethod write-system-index ((bundle bundle) stream) 197 | (dolist (release (provided-releases bundle)) 198 | ;; Working with strings, here, intentionally not with pathnames 199 | (let ((prefix (concatenate 'string "software/" (prefix release)))) 200 | (dolist (system-file (system-files release)) 201 | (format stream "~A/~A~%" prefix system-file))))) 202 | 203 | (defmethod write-loader-script ((bundle bundle) stream) 204 | (let ((template-lines 205 | (load-time-value 206 | ;; On Genera, the semantics of Unix pathnames cause merging a filename with 207 | ;; no type against defaults with a type to leave the type as :UNSPECIFIC. 208 | ;; So, explicitly provide the type here to avoid that problem. (I'm not 209 | ;; sure what would happen if I were to change that behavior. --Palter) 210 | (with-open-file (stream #. (merge-pathnames "bundle-template.lisp" 211 | (or *compile-file-truename* 212 | *load-truename*))) 213 | (loop for line = (read-line stream nil) 214 | while line collect line))))) 215 | (dolist (line template-lines) 216 | (write-line line stream)))) 217 | 218 | (defun coerce-to-directory (pathname) 219 | ;; Cribbed from quicklisp-bootstrap/quicklisp.lisp 220 | (let ((name (file-namestring pathname))) 221 | (if (or (null name) 222 | (equal name "")) 223 | pathname 224 | (make-pathname :defaults pathname 225 | :name nil 226 | :type nil 227 | :directory (append (pathname-directory pathname) 228 | (list name)))))) 229 | 230 | (defun bundle-metadata-plist (bundle) 231 | (list :creation-time (creation-time bundle) 232 | :requested-systems (requested-systems bundle) 233 | :lisp-info (list :machine-instance (machine-instance) 234 | :machine-type (machine-type) 235 | :machine-version (machine-version) 236 | :lisp-implementation-type (lisp-implementation-type) 237 | :lisp-implementation-version (lisp-implementation-version)) 238 | :quicklisp-info (list :home (namestring ql:*quicklisp-home*) 239 | :local-project-directories 240 | (mapcar 'namestring ql:*local-project-directories*) 241 | :dists 242 | (loop for dist in (enabled-dists) 243 | collect (list :name (name dist) 244 | :dist-url 245 | (canonical-distinfo-url dist) 246 | :version (version dist)))))) 247 | 248 | (defmethod write-bundle ((bundle bundle) target) 249 | (unpack-releases bundle target) 250 | (let ((index-file (merge-pathnames "system-index.txt" target)) 251 | (loader-file (merge-pathnames "bundle.lisp" target)) 252 | (local-projects (merge-pathnames "local-projects/" target)) 253 | (metadata-file (merge-pathnames "bundle-info.sexp" target))) 254 | (ensure-directories-exist local-projects) 255 | (with-open-file (stream index-file :direction :output 256 | :if-exists :supersede) 257 | (write-system-index bundle stream)) 258 | (with-open-file (stream loader-file :direction :output 259 | :if-exists :supersede) 260 | (write-loader-script bundle stream)) 261 | (with-open-file (stream metadata-file :direction :output 262 | :if-exists :supersede) 263 | (with-standard-io-syntax 264 | (let ((*print-pretty* t)) 265 | (prin1 (bundle-metadata-plist bundle) stream) 266 | (terpri stream)))) 267 | (probe-file loader-file))) 268 | 269 | 270 | (defun copy-file (from-file to-file) 271 | (with-open-file (from-stream from-file :element-type '(unsigned-byte 8) 272 | :if-does-not-exist nil) 273 | (when from-stream 274 | (let ((buffer (make-array 10000 :element-type '(unsigned-byte 8)))) 275 | (with-open-file (to-stream to-file 276 | :direction :output 277 | :if-exists :supersede 278 | :element-type '(unsigned-byte 8)) 279 | (loop 280 | (let ((end-index (read-sequence buffer from-stream))) 281 | (when (zerop end-index) 282 | (return to-file)) 283 | (write-sequence buffer to-stream :end end-index)))))))) 284 | 285 | (defun copy-directory-tree (from-directory to-directory) 286 | ;; Use the truename here to ensure that relative pathnames match up 287 | ;; properly. For example, on SBCL, "~/foo/bar/" entries are not 288 | ;; relative to "/home/baz/foo/bar/" entries. 289 | (setf from-directory (truename from-directory)) 290 | (map-directory-tree 291 | from-directory 292 | (lambda (from-pathname) 293 | (when (probe-file from-pathname) 294 | (let* ((relative (enough-namestring from-pathname from-directory)) 295 | (relative-directory (pathname-directory relative)) 296 | (to-pathname (merge-pathnames relative to-directory))) 297 | (unless (or (null relative-directory) 298 | (eql (first relative-directory) 299 | :relative)) 300 | (error "Expected relative pathname to copy from ~A ~ 301 | - bad symlink? - ~S" 302 | from-pathname 303 | relative)) 304 | (ensure-directories-exist to-pathname) 305 | (copy-file from-pathname to-pathname)))))) 306 | 307 | (defun copy-local-projects-directories (local-projects-directories 308 | to-directory) 309 | "Copy the local-projects directories to TO-DIRECTORY. Each one gets 310 | a distinct subdirectory." 311 | (loop for prefix from 0 312 | for prefix-directory = (make-pathname :directory 313 | (list :relative 314 | (format nil "~4,'0X" prefix))) 315 | for from-directory in local-projects-directories 316 | for real-to-directory = (merge-pathnames prefix-directory to-directory) 317 | do 318 | (format *bundle-progress-output* 319 | "~&; Copying ~A to bundle..." from-directory ) 320 | (force-output *bundle-progress-output*) 321 | (ensure-directories-exist real-to-directory) 322 | (copy-directory-tree from-directory real-to-directory) 323 | (format *bundle-progress-output* "done.~%") 324 | (force-output *bundle-progress-output*))) 325 | 326 | 327 | (defun ql:bundle-systems (system-names 328 | &key include-local-projects to (overwrite t)) 329 | "In the directory TO, construct a self-contained bundle of libraries 330 | based on SYSTEM-NAMES. For each system named, and its recursive 331 | required systems, unpack its release archive in TO/software/, and 332 | write a system index, compatible with the output of 333 | QL:WRITE-ASDF-MANIFEST-FILE, to TO/system-index.txt. Write a loader 334 | script to TO/bundle.lisp that, when loaded via CL:LOAD, configures 335 | ASDF to load systems from the bundle before any other system. 336 | 337 | SYSTEM-NAMES must name systems provided directly by Quicklisp. 338 | 339 | If INCLUDE-LOCAL-PROJECTS is true, each directory in 340 | QL:*LOCAL-PROJECT-DIRECTORIES* is copied into the bundle and loaded 341 | before any of the other bundled systems." 342 | (unless to 343 | (error "TO argument must be provided")) 344 | (let* ((bundle (make-instance 'bundle 345 | :requested-systems system-names)) 346 | (to (coerce-to-directory to)) 347 | (software (merge-pathnames "software/" to))) 348 | (when (and (probe-directory to) 349 | (not overwrite)) 350 | (cerror "Overwrite it" 351 | 'bundle-directory-exists 352 | :directory to)) 353 | (when (probe-directory software) 354 | (delete-directory-tree software)) 355 | (add-systems-recursively system-names bundle) 356 | (let ((bundled-local-projects (merge-pathnames "bundled-local-projects/" 357 | to))) 358 | (when include-local-projects 359 | (when (probe-directory bundled-local-projects) 360 | (delete-directory-tree bundled-local-projects)) 361 | (copy-local-projects-directories ql:*local-project-directories* 362 | bundled-local-projects) 363 | (ensure-directories-exist bundled-local-projects) 364 | (ql::make-system-index bundled-local-projects))) 365 | (values (write-bundle bundle to) 366 | bundle))) 367 | -------------------------------------------------------------------------------- /quicklisp/cdb.lisp: -------------------------------------------------------------------------------- 1 | ;;;; cdb.lisp 2 | 3 | (in-package #:ql-cdb) 4 | 5 | (defconstant +initial-hash-value+ 5381) 6 | 7 | (defun cdb-hash (octets) 8 | "http://cr.yp.to/cdb/cdb.txt" 9 | (declare (type (simple-array (unsigned-byte 8) (*)) octets) 10 | (optimize speed)) 11 | (let ((h +initial-hash-value+)) 12 | (declare (type (unsigned-byte 32) h)) 13 | (dotimes (i (length octets) h) 14 | (let ((c (aref octets i))) 15 | (setf h (logand #xFFFFFFFF (+ h (ash h 5)))) 16 | (setf h (logxor h c)))))) 17 | 18 | (defun make-growable-vector (&key 19 | (size 10) (element-type t)) 20 | (make-array size :fill-pointer 0 :adjustable t :element-type element-type)) 21 | 22 | (defun make-octet-vector (size) 23 | (make-array size :element-type '(unsigned-byte 8))) 24 | 25 | (defun encode-string (string) 26 | "Do a bare-bones ASCII encoding of STRING." 27 | (map-into (make-octet-vector (length string)) 28 | 'char-code 29 | string)) 30 | 31 | (defun decode-octets (octets) 32 | "Do a bare-bones ASCII decoding of OCTETS." 33 | (map-into (make-string (length octets)) 34 | 'code-char 35 | octets)) 36 | 37 | (defun read-cdb-u32 (stream) 38 | (logand #xFFFFFFFF 39 | (logior (ash (read-byte stream) 0) 40 | (ash (read-byte stream) 8) 41 | (ash (read-byte stream) 16) 42 | (ash (read-byte stream) 24)))) 43 | 44 | (defun lookup-record-at (position key stream) 45 | (file-position stream position) 46 | (let ((key-size (read-cdb-u32 stream)) 47 | (value-size (read-cdb-u32 stream))) 48 | (when (= key-size (length key)) 49 | (let ((test-key (make-octet-vector key-size))) 50 | (when (/= key-size (read-sequence test-key stream)) 51 | (error "Could not read record key of size ~D from cdb stream" 52 | key-size)) 53 | (unless (mismatch test-key key :test #'=) 54 | (let ((value (make-octet-vector value-size))) 55 | (if (= value-size (read-sequence value stream)) 56 | value 57 | (error "Could not read record value of size ~D from cdb stream" 58 | value-size)))))))) 59 | 60 | (defun table-slot-lookup (key hash table-position 61 | initial-slot slot-count stream) 62 | (let ((slot initial-slot)) 63 | (loop 64 | (file-position stream (+ table-position (* slot 8))) 65 | (let ((test-hash (read-cdb-u32 stream)) 66 | (record-position (read-cdb-u32 stream))) 67 | (when (zerop record-position) 68 | (return)) 69 | (when (= hash test-hash) 70 | (let ((value (lookup-record-at record-position key stream))) 71 | (when value 72 | (return value))))) 73 | (setf slot (mod (1+ slot) slot-count))))) 74 | 75 | (defun stream-lookup (key stream) 76 | (let* ((hash (cdb-hash key)) 77 | (pointer-index (logand #xFF hash))) 78 | (file-position stream (* pointer-index 8)) 79 | (let ((table-position (read-cdb-u32 stream)) 80 | (slot-count (read-cdb-u32 stream))) 81 | (when (plusp slot-count) 82 | (let ((initial-slot (mod (ash hash -8) slot-count))) 83 | (table-slot-lookup key hash 84 | table-position initial-slot slot-count stream)))))) 85 | 86 | (defun %lookup (key cdb) 87 | "Return the value for KEY in CDB, or NIL if no matching key is 88 | found. CDB should be a pathname or an open octet stream. The key 89 | should be a vector of octets. The returned value will be a vector of 90 | octets." 91 | (if (streamp cdb) 92 | (stream-lookup key cdb) 93 | (with-open-file (stream cdb :element-type '(unsigned-byte 8)) 94 | (stream-lookup key stream)))) 95 | 96 | (defun lookup (key cdb) 97 | "Return the value for KEY in CDB, or NIL if no matching key is 98 | found. CDB should be a pathname or an open octet stream. The key 99 | should be an ASCII-encodable string. The returned value will be a 100 | string." 101 | (let ((value (%lookup (encode-string key) cdb))) 102 | (when value 103 | (decode-octets value)))) 104 | 105 | (defun stream-map-cdb (function stream) 106 | (labels ((map-one-slot (i) 107 | (file-position stream (* i 8)) 108 | (let ((table-position (read-cdb-u32 stream)) 109 | (slot-count (read-cdb-u32 stream))) 110 | (when (plusp slot-count) 111 | (map-one-table table-position slot-count)))) 112 | (map-one-table (position count) 113 | (dotimes (i count) 114 | (file-position stream (+ position (* i 8))) 115 | (let ((hash (read-cdb-u32 stream)) 116 | (position (read-cdb-u32 stream))) 117 | (declare (ignore hash)) 118 | (when (plusp position) 119 | (map-record position))))) 120 | (map-record (position) 121 | (file-position stream position) 122 | (let* ((key-size (read-cdb-u32 stream)) 123 | (value-size (read-cdb-u32 stream)) 124 | (key (make-octet-vector key-size)) 125 | (value (make-octet-vector value-size))) 126 | (read-sequence key stream) 127 | (read-sequence value stream) 128 | (funcall function key value)))) 129 | (dotimes (i 256) 130 | (map-one-slot i)))) 131 | 132 | (defun %map-cdb (function cdb) 133 | "Call FUNCTION once with each key and value in CDB." 134 | (if (streamp cdb) 135 | (stream-map-cdb function cdb) 136 | (with-open-file (stream cdb :element-type '(unsigned-byte 8)) 137 | (stream-map-cdb function stream)))) 138 | 139 | (defun map-cdb (function cdb) 140 | (%map-cdb (lambda (key value) 141 | (funcall function 142 | (decode-octets key) 143 | (decode-octets value))) 144 | cdb)) 145 | 146 | 147 | ;;; Writing CDB files 148 | 149 | (defun write-cdb-u32 (u32 stream) 150 | "Write an (unsigned-byte 32) value to STREAM in little-endian order." 151 | (write-byte (ldb (byte 8 0) u32) stream) 152 | (write-byte (ldb (byte 8 8) u32) stream) 153 | (write-byte (ldb (byte 8 16) u32) stream) 154 | (write-byte (ldb (byte 8 24) u32) stream)) 155 | 156 | (defclass record-pointer () 157 | ((hash-value 158 | :initarg :hash-value 159 | :accessor hash-value 160 | :documentation "The hash value of the record key.") 161 | (record-position 162 | :initarg :record-position 163 | :accessor record-position 164 | :documentation "The file position at which the record is stored.")) 165 | (:default-initargs 166 | :hash-value 0 167 | :record-position 0) 168 | (:documentation "Every key/value record written to a CDB has a 169 | corresponding record pointer, which tracks the key's hash value and 170 | the record's position in the data file. When all records have been 171 | written to the file, these record pointers are organized into hash 172 | tables at the end of the cdb file.")) 173 | 174 | (defmethod print-object ((record-pointer record-pointer) stream) 175 | (print-unreadable-object (record-pointer stream :type t) 176 | (format stream "~8,'0X@~:D" 177 | (hash-value record-pointer) 178 | (record-position record-pointer)))) 179 | 180 | (defvar *empty-record-pointer* (make-instance 'record-pointer)) 181 | 182 | 183 | (defclass hash-table-bucket () 184 | ((table-position 185 | :initarg :table-position 186 | :accessor table-position 187 | :documentation "The file position at which this table 188 | is (eventually) slotted.") 189 | (entries 190 | :initarg :entries 191 | :accessor entries 192 | :documentation "A vector of record-pointers.")) 193 | (:default-initargs 194 | :table-position 0 195 | :entries (make-growable-vector)) 196 | (:documentation "During construction of the CDB, record pointers are 197 | accumulated into one of 256 hash table buckets, depending on the low 198 | 8 bits of the hash value of the key. At the end of record writing, 199 | these buckets are used to write out hash table vectors at the end of 200 | the file, and write pointers to the hash table vectors at the start 201 | of the file.")) 202 | 203 | (defgeneric entry-count (object) 204 | (:method ((object hash-table-bucket)) 205 | (length (entries object)))) 206 | 207 | (defgeneric slot-count (object) 208 | (:method ((object hash-table-bucket)) 209 | (* (entry-count object) 2))) 210 | 211 | (defun bucket-hash-vector (bucket) 212 | "Create a hash vector for a bucket. A hash vector has 2x the entries 213 | of the bucket, and is initialized to an empty record pointer. The high 214 | 24 bits of the hash value of a record pointer, mod the size of the 215 | vector, is used as a starting slot, and the vector is walked (wrapping 216 | at the end) to find the first free slot for positioning each record 217 | pointer entry." 218 | (let* ((size (slot-count bucket)) 219 | (vector (make-array size :initial-element nil))) 220 | (flet ((slot (record) 221 | (let ((index (mod (ash (hash-value record) -8) size))) 222 | (loop 223 | (unless (aref vector index) 224 | (return (setf (aref vector index) record))) 225 | (setf index (mod (1+ index) size)))))) 226 | (map nil #'slot (entries bucket))) 227 | (nsubstitute *empty-record-pointer* nil vector))) 228 | 229 | (defmethod print-object ((bucket hash-table-bucket) stream) 230 | (print-unreadable-object (bucket stream :type t) 231 | (format stream "~D entr~:@P" (entry-count bucket)))) 232 | 233 | 234 | (defclass cdb-writer () 235 | ((buckets 236 | :initarg :buckets 237 | :accessor buckets) 238 | (end-of-records-position 239 | :initarg :end-of-records-position 240 | :accessor end-of-records-position) 241 | (output 242 | :initarg :output 243 | :accessor output)) 244 | (:default-initargs 245 | :end-of-records-position 2048 246 | :buckets (map-into (make-array 256) 247 | (lambda () (make-instance 'hash-table-bucket))))) 248 | 249 | 250 | (defun add-record (key value cdb-writer) 251 | "Add KEY and VALUE to a cdb file. KEY and VALUE should both 252 | be (unsigned-byte 8) vectors." 253 | (let* ((output (output cdb-writer)) 254 | (hash-value (cdb-hash key)) 255 | (bucket-index (logand #xFF hash-value)) 256 | (bucket (aref (buckets cdb-writer) bucket-index)) 257 | (record-position (file-position output)) 258 | (record-pointer (make-instance 'record-pointer 259 | :record-position record-position 260 | :hash-value hash-value))) 261 | (vector-push-extend record-pointer (entries bucket)) 262 | (write-cdb-u32 (length key) output) 263 | (write-cdb-u32 (length value) output) 264 | (write-sequence key output) 265 | (write-sequence value output) 266 | (force-output output) 267 | (incf (end-of-records-position cdb-writer) 268 | (+ 8 (length key) (length value))))) 269 | 270 | (defun write-bucket-hash-table (bucket stream) 271 | "Write BUCKET's hash table vector to STREAM." 272 | (map nil 273 | (lambda (pointer) 274 | (write-cdb-u32 (hash-value pointer) stream) 275 | (write-cdb-u32 (record-position pointer) stream)) 276 | (bucket-hash-vector bucket))) 277 | 278 | (defun write-hash-tables (cdb-writer) 279 | "Write the traililng hash tables to the end of the cdb 280 | file. Initializes the position of the buckets in the process." 281 | (let ((stream (output cdb-writer))) 282 | (map nil 283 | (lambda (bucket) 284 | (setf (table-position bucket) (file-position stream)) 285 | (write-bucket-hash-table bucket stream)) 286 | (buckets cdb-writer)))) 287 | 288 | (defun write-pointers (cdb-writer) 289 | "Write the leading hash table pointers to the beginning of the cdb 290 | file. Must be called after WRITE-HASH-TABLES, or the positions won't 291 | be available." 292 | (let ((stream (output cdb-writer))) 293 | (file-position stream :start) 294 | (map nil 295 | (lambda (bucket) 296 | (let ((position (table-position bucket)) 297 | (count (slot-count bucket))) 298 | (when (zerop position) 299 | (error "Table positions not initialized correctly")) 300 | (write-cdb-u32 position stream) 301 | (write-cdb-u32 count stream))) 302 | (buckets cdb-writer)))) 303 | 304 | (defun finish-cdb-writer (cdb-writer) 305 | "Write the trailing hash tables and leading table pointers to the 306 | cdb file." 307 | (write-hash-tables cdb-writer) 308 | (write-pointers cdb-writer) 309 | (force-output (output cdb-writer))) 310 | 311 | 312 | (defvar *pointer-padding* (make-array 2048 :element-type '( unsigned-byte 8))) 313 | 314 | (defun call-with-output-to-cdb (cdb-pathname temp-pathname fun) 315 | "Call FUN with one argument, a CDB-WRITER instance to which records 316 | can be added with ADD-RECORD." 317 | (with-open-file (stream temp-pathname 318 | :direction :output 319 | :element-type '(unsigned-byte 8) 320 | :if-exists :supersede) 321 | (let ((cdb (make-instance 'cdb-writer :output stream))) 322 | (write-sequence *pointer-padding* stream) 323 | (funcall fun cdb) 324 | (finish-cdb-writer cdb))) 325 | (values (rename-file temp-pathname cdb-pathname))) 326 | 327 | (defmacro with-output-to-cdb ((cdb file temp-file) &body body) 328 | "Evaluate BODY with CDB bound to a CDB-WRITER object. The CDB in 329 | progress is written to TEMP-FILE, and then when the CDB is 330 | successfully written, TEMP-FILE is renamed to FILE. For atomic 331 | operation, FILE and TEMP-FILE must be on the same filesystem." 332 | `(call-with-output-to-cdb ,file ,temp-file 333 | (lambda (,cdb) 334 | ,@body))) 335 | 336 | 337 | ;;; Index file (systems.txt, releases.txt) conversion 338 | 339 | (defun convert-index-file (index-file 340 | &key (cdb-file (make-pathname :type "cdb" 341 | :defaults index-file)) 342 | (index 0)) 343 | (with-open-file (stream index-file) 344 | (let ((header (read-line stream))) 345 | (unless (and (plusp (length header)) 346 | (char= (char header 0) #\#)) 347 | (error "Bad header line in ~A -- ~S" 348 | index-file header))) 349 | (with-output-to-cdb (cdb cdb-file (make-pathname :type "cdb-tmp" 350 | :defaults cdb-file)) 351 | (loop for line = (read-line stream nil) 352 | for words = (and line (ql-util:split-spaces line)) 353 | while line do 354 | (add-record (encode-string (elt words index)) 355 | (encode-string line) 356 | cdb))))) 357 | -------------------------------------------------------------------------------- /quicklisp/client-info.lisp: -------------------------------------------------------------------------------- 1 | ;;;; client-info.lisp 2 | 3 | (in-package #:quicklisp-client) 4 | 5 | (defparameter *client-base-url* "http://beta.quicklisp.org/") 6 | 7 | (defgeneric info-equal (info1 info2) 8 | (:documentation "Return TRUE if INFO1 and INFO2 are 'equal' in some 9 | important sense.")) 10 | 11 | ;;; Information for checking the validity of files fetched for 12 | ;;; installing/updating the client code. 13 | 14 | (defclass client-file-info () 15 | ((plist-key 16 | :initarg :plist-key 17 | :reader plist-key) 18 | (file-url 19 | :initarg :url 20 | :reader file-url) 21 | (name 22 | :reader name 23 | :initarg :name) 24 | (size 25 | :initarg :size 26 | :reader size) 27 | (md5 28 | :reader md5 29 | :initarg :md5) 30 | (sha256 31 | :reader sha256 32 | :initarg :sha256) 33 | (plist 34 | :reader plist 35 | :initarg :plist))) 36 | 37 | (defmethod print-object ((info client-file-info) stream) 38 | (print-unreadable-object (info stream :type t) 39 | (format stream "~S ~D ~S" 40 | (name info) 41 | (size info) 42 | (md5 info)))) 43 | 44 | (defmethod info-equal ((info1 client-file-info) (info2 client-file-info)) 45 | (and (eql (size info1) (size info2)) 46 | (equal (name info1) (name info2)) 47 | (equal (md5 info1) (md5 info2)))) 48 | 49 | (defclass asdf-file-info (client-file-info) 50 | () 51 | (:default-initargs 52 | :plist-key :asdf 53 | :name "asdf.lisp")) 54 | 55 | (defclass setup-file-info (client-file-info) 56 | () 57 | (:default-initargs 58 | :plist-key :setup 59 | :name "setup.lisp")) 60 | 61 | (defclass client-tar-file-info (client-file-info) 62 | () 63 | (:default-initargs 64 | :plist-key :client-tar 65 | :name "quicklisp.tar")) 66 | 67 | (define-condition invalid-client-file (error) 68 | ((file 69 | :initarg :file 70 | :reader invalid-client-file-file))) 71 | 72 | (define-condition badly-sized-client-file (invalid-client-file) 73 | ((expected-size 74 | :initarg :expected-size 75 | :reader badly-sized-client-file-expected-size) 76 | (actual-size 77 | :initarg :actual-size 78 | :reader badly-sized-client-file-actual-size)) 79 | (:report (lambda (condition stream) 80 | (format stream "Unexpected file size for ~A ~ 81 | - expected ~A but got ~A" 82 | (invalid-client-file-file condition) 83 | (badly-sized-client-file-expected-size condition) 84 | (badly-sized-client-file-actual-size condition))))) 85 | 86 | (defun check-client-file-size (file expected-size) 87 | (let ((actual-size (file-size file))) 88 | (unless (eql expected-size actual-size) 89 | (error 'badly-sized-client-file 90 | :file file 91 | :expected-size expected-size 92 | :actual-size actual-size)))) 93 | 94 | ;;; TODO: check cryptographic digests too. 95 | 96 | (defgeneric check-client-file (file client-file-info) 97 | (:documentation 98 | "Signal an INVALID-CLIENT-FILE error if FILE does not match the 99 | metadata in CLIENT-FILE-INFO.") 100 | (:method (file client-file-info) 101 | (check-client-file-size file (size client-file-info)) 102 | client-file-info)) 103 | 104 | ;;; Structuring and loading information about the Quicklisp client 105 | ;;; code 106 | 107 | (defclass client-info () 108 | ((setup-info 109 | :reader setup-info 110 | :initarg :setup-info) 111 | (asdf-info 112 | :reader asdf-info 113 | :initarg :asdf-info) 114 | (client-tar-info 115 | :reader client-tar-info 116 | :initarg :client-tar-info) 117 | (canonical-client-info-url 118 | :reader canonical-client-info-url 119 | :initarg :canonical-client-info-url) 120 | (version 121 | :reader version 122 | :initarg :version) 123 | (subscription-url 124 | :reader subscription-url 125 | :initarg :subscription-url) 126 | (plist 127 | :reader plist 128 | :initarg :plist) 129 | (source-file 130 | :reader source-file 131 | :initarg :source-file))) 132 | 133 | (defmethod print-object ((client-info client-info) stream) 134 | (print-unreadable-object (client-info stream :type t) 135 | (prin1 (version client-info) stream))) 136 | 137 | (defmethod available-versions-url ((info client-info)) 138 | (make-versions-url (subscription-url info))) 139 | 140 | (defgeneric extract-client-file-info (file-info-class plist) 141 | (:method (file-info-class plist) 142 | (let* ((instance (make-instance file-info-class)) 143 | (key (plist-key instance)) 144 | (file-info-plist (getf plist key))) 145 | (unless file-info-plist 146 | (error "Missing client-info data for ~S" key)) 147 | (destructuring-bind (&key url size md5 sha256 &allow-other-keys) 148 | file-info-plist 149 | (unless (and url size md5 sha256) 150 | (error "Missing client-info data for ~S" key)) 151 | (reinitialize-instance instance 152 | :plist file-info-plist 153 | :url url 154 | :size size 155 | :md5 md5 156 | :sha256 sha256))))) 157 | 158 | (defun format-client-url (path &rest format-arguments) 159 | (if format-arguments 160 | (format nil "~A~{~}" *client-base-url* path format-arguments) 161 | (format nil "~A~A" *client-base-url* path))) 162 | 163 | (defun client-info-url-from-version (version) 164 | (format-client-url "client/~A/client-info.sexp" version)) 165 | 166 | (define-condition invalid-client-info (error) 167 | ((plist 168 | :initarg plist 169 | :reader invalid-client-info-plist))) 170 | 171 | (defun load-client-info (file) 172 | (let ((plist (safely-read-file file))) 173 | (destructuring-bind (&key subscription-url 174 | version 175 | canonical-client-info-url 176 | &allow-other-keys) 177 | plist 178 | (make-instance 'client-info 179 | :setup-info (extract-client-file-info 'setup-file-info 180 | plist) 181 | :asdf-info (extract-client-file-info 'asdf-file-info 182 | plist) 183 | :client-tar-info 184 | (extract-client-file-info 'client-tar-file-info 185 | plist) 186 | :canonical-client-info-url canonical-client-info-url 187 | :version version 188 | :subscription-url subscription-url 189 | :plist plist 190 | :source-file (probe-file file))))) 191 | 192 | (defun mock-client-info () 193 | (flet ((mock-client-file-info (class) 194 | (make-instance class 195 | :size 0 196 | :url "" 197 | :md5 "" 198 | :sha256 "" 199 | :plist nil))) 200 | (make-instance 'client-info 201 | :version ql-info:*version* 202 | :subscription-url 203 | (format-client-url "client/quicklisp.sexp") 204 | :setup-info (mock-client-file-info 'setup-file-info) 205 | :asdf-info (mock-client-file-info 'asdf-file-info) 206 | :client-tar-info (mock-client-file-info 207 | 'client-tar-file-info)))) 208 | 209 | (defun fetch-client-info (url) 210 | (let ((info-file (qmerge "tmp/client-info.sexp"))) 211 | (delete-file-if-exists info-file) 212 | (fetch url info-file :quietly t) 213 | (handler-case 214 | (load-client-info info-file) 215 | ;; FIXME: So many other things could go wrong here; I think it 216 | ;; would be nice to catch and report them clearly as bogus URLs 217 | (invalid-client-info () 218 | (error "Invalid client info URL -- ~A" url))))) 219 | 220 | (defun local-client-info () 221 | (let ((info-file (qmerge "client-info.sexp"))) 222 | (cond ((probe-file info-file) 223 | (load-client-info info-file)) 224 | (t 225 | (warn "Missing client-info.sexp, using mock info") 226 | (mock-client-info))))) 227 | 228 | (defun newest-client-info (&optional (info (local-client-info))) 229 | (let ((latest (subscription-url info))) 230 | (when latest 231 | (fetch-client-info latest)))) 232 | 233 | (defun client-version-lessp (client-info-1 client-info-2) 234 | (string-lessp (version client-info-1) 235 | (version client-info-2))) 236 | 237 | (defun client-version () 238 | "Return the version for the current local client installation. May 239 | or may not be suitable for passing as the :VERSION argument to 240 | INSTALL-CLIENT, depending on if it's a standard Quicklisp-provided 241 | client." 242 | (version (local-client-info))) 243 | 244 | (defun client-url () 245 | "Return an URL suitable for passing as the :URL argument to 246 | INSTALL-CLIENT for the current local client installation." 247 | (canonical-client-info-url (local-client-info))) 248 | 249 | (defun available-client-versions () 250 | (let ((url (available-versions-url (local-client-info))) 251 | (temp-file (qmerge "tmp/client-versions.sexp"))) 252 | (when url 253 | (handler-case 254 | (progn 255 | (maybe-fetch-gzipped url temp-file) 256 | (prog1 257 | (with-open-file (stream temp-file) 258 | (safely-read stream)) 259 | (delete-file-if-exists temp-file))) 260 | (unexpected-http-status (condition) 261 | (unless (url-not-suitable-error-p condition) 262 | (error condition))))))) 263 | -------------------------------------------------------------------------------- /quicklisp/client-update.lisp: -------------------------------------------------------------------------------- 1 | ;;;; client-update.lisp 2 | 3 | (in-package #:quicklisp-client) 4 | 5 | (defun fetch-client-file-info (client-file-info output-file) 6 | (maybe-fetch-gzipped (file-url client-file-info) output-file) 7 | (check-client-file output-file client-file-info) 8 | (probe-file output-file)) 9 | 10 | (defun retirement-directory (base) 11 | (let ((suffix 0)) 12 | (loop 13 | (incf suffix) 14 | (let* ((try (format nil "~A-~D" base suffix)) 15 | (dir (qmerge (make-pathname :directory 16 | (list :relative "retired" try))))) 17 | (unless (probe-directory dir) 18 | (return dir)))))) 19 | 20 | (defun retire (directory base) 21 | (let ((retirement-home (qmerge "retired/")) 22 | (from (truename directory))) 23 | (ensure-directories-exist retirement-home) 24 | (let* ((*default-pathname-defaults* retirement-home) 25 | (to (retirement-directory base))) 26 | (rename-directory from to) 27 | to))) 28 | 29 | (defun client-update-scratch-directory (client-info) 30 | (qmerge (make-pathname :directory 31 | (list :relative 32 | "tmp" 33 | "client-update" 34 | (version client-info))))) 35 | 36 | (defun %install-client (new-info local-info) 37 | (let* ((work-directory (client-update-scratch-directory new-info)) 38 | (current-quicklisp-directory (qmerge "quicklisp/")) 39 | (new-quicklisp-directory 40 | (merge-pathnames "quicklisp/" work-directory)) 41 | (local-temp-tar (merge-pathnames "quicklisp.tar" work-directory)) 42 | (local-setup (merge-pathnames "setup.lisp" work-directory)) 43 | (local-asdf (merge-pathnames "asdf.lisp" work-directory)) 44 | (new-client-tar-p (not (info-equal (client-tar-info new-info) 45 | (client-tar-info local-info)))) 46 | (new-setup-p (not (info-equal (setup-info new-info) 47 | (setup-info local-info)))) 48 | (new-asdf-p (not (info-equal (asdf-info new-info) 49 | (asdf-info local-info))))) 50 | (ensure-directories-exist work-directory) 51 | ;; Fetch and unpack quicklisp.tar if needed 52 | (when new-client-tar-p 53 | (fetch-client-file-info (client-tar-info new-info) local-temp-tar) 54 | (unpack-tarball local-temp-tar :directory work-directory)) 55 | ;; Fetch setup.lisp if needed 56 | (when new-setup-p 57 | (fetch-client-file-info (setup-info new-info) local-setup)) 58 | ;; Fetch asdf.lisp if needed 59 | (when new-asdf-p 60 | (fetch-client-file-info (asdf-info new-info) local-asdf)) 61 | ;; Everything fetched, so move the old stuff away and move the new 62 | ;; stuff in 63 | (when new-client-tar-p 64 | (retire (qmerge "quicklisp/") 65 | (format nil "quicklisp-~A" 66 | (version local-info))) 67 | (rename-directory new-quicklisp-directory current-quicklisp-directory)) 68 | (when new-setup-p 69 | (replace-file local-setup (qmerge "setup.lisp"))) 70 | (when new-asdf-p 71 | (replace-file local-asdf (qmerge "asdf.lisp"))) 72 | ;; But unconditionally move the new client-info into place 73 | (replace-file (source-file new-info) (qmerge "client-info.sexp")) 74 | new-info)) 75 | 76 | (defun update-client (&key (prompt t)) 77 | (let* ((local-info (local-client-info)) 78 | (newest-info (newest-client-info local-info))) 79 | (cond ((null newest-info) 80 | (format t "No client update available.~%")) 81 | ((client-version-lessp local-info newest-info) 82 | (format t "Updating client from version ~A to version ~A.~%" 83 | (version local-info) 84 | (version newest-info)) 85 | (when (or (not prompt) 86 | (press-enter-to-continue)) 87 | (%install-client newest-info local-info) 88 | (format t "~&New Quicklisp client installed. ~ 89 | It will take effect on restart.~%"))) 90 | (t 91 | (format t "The most up-to-date client, version ~A, ~ 92 | is already installed.~%" 93 | (version local-info))))) 94 | t) 95 | 96 | 97 | (defun install-client (&key url version) 98 | (unless (or url version) 99 | (error "One of ~S or ~S is required" :url :version)) 100 | (when (and url version) 101 | (error "Only one of ~S or ~S is allowed" :url :version)) 102 | (when version 103 | (setf url (client-info-url-from-version version))) 104 | (let ((local-info (local-client-info)) 105 | (new-info (fetch-client-info url))) 106 | (%install-client new-info local-info))) 107 | -------------------------------------------------------------------------------- /quicklisp/client.lisp: -------------------------------------------------------------------------------- 1 | ;;;; client.lisp 2 | 3 | (in-package #:quicklisp-client) 4 | 5 | (defvar *quickload-verbose* nil 6 | "When NIL, show terse output when quickloading a system. Otherwise, 7 | show normal compile and load output.") 8 | 9 | (defvar *quickload-prompt* nil 10 | "When NIL, quickload systems without prompting for enter to 11 | continue, otherwise proceed directly without user intervention.") 12 | 13 | (defvar *quickload-explain* t) 14 | 15 | (define-condition system-not-quickloadable (error) 16 | ((system 17 | :initarg :system 18 | :reader not-quickloadable-system))) 19 | 20 | (defun maybe-silence (silent stream) 21 | (or (and silent (make-broadcast-stream)) stream)) 22 | 23 | (defgeneric quickload (systems &key verbose silent prompt explain &allow-other-keys) 24 | (:documentation 25 | "Load SYSTEMS the quicklisp way. SYSTEMS is a designator for a list 26 | of things to be loaded.") 27 | (:method (systems &key 28 | (prompt *quickload-prompt*) 29 | (silent nil) 30 | (verbose *quickload-verbose*) &allow-other-keys) 31 | (let ((*standard-output* (maybe-silence silent *standard-output*)) 32 | (*trace-output* (maybe-silence silent *trace-output*))) 33 | (unless (listp systems) 34 | (setf systems (list systems))) 35 | (dolist (thing systems systems) 36 | (flet ((ql () 37 | (autoload-system-and-dependencies (name thing) 38 | :prompt prompt))) 39 | (tagbody :start 40 | (restart-case (if verbose 41 | (ql) 42 | (call-with-quiet-compilation #'ql)) 43 | (register-local-projects () 44 | :report "Register local projects and try again." 45 | (register-local-projects) 46 | (go :start))))))))) 47 | 48 | (defmethod quickload :around (systems &key verbose prompt explain 49 | &allow-other-keys) 50 | (declare (ignorable systems verbose prompt explain)) 51 | (with-consistent-dists 52 | (call-next-method))) 53 | 54 | (defun system-list () 55 | (provided-systems t)) 56 | 57 | (defun update-dist (dist &key (prompt t)) 58 | (when (stringp dist) 59 | (setf dist (find-dist dist))) 60 | (let ((new (available-update dist))) 61 | (cond (new 62 | (show-update-report dist new) 63 | (when (or (not prompt) (press-enter-to-continue)) 64 | (update-in-place dist new))) 65 | ((not (subscribedp dist)) 66 | (format t "~&You are not subscribed to ~S." 67 | (name dist))) 68 | (t 69 | (format t "~&You already have the latest version of ~S: ~A.~%" 70 | (name dist) 71 | (version dist)))))) 72 | 73 | (defun update-all-dists (&key (prompt t)) 74 | (let ((dists (remove-if-not 'subscribedp (all-dists)))) 75 | (format t "~&~D dist~:P to check.~%" (length dists)) 76 | (dolist (old dists) 77 | (with-simple-restart (skip "Skip update of dist ~S" (name old)) 78 | (update-dist old :prompt prompt))))) 79 | 80 | (defun available-dist-versions (name) 81 | (available-versions (find-dist-or-lose name))) 82 | 83 | (defun help () 84 | "For help with Quicklisp, see http://www.quicklisp.org/beta/") 85 | 86 | (defun uninstall (system-name) 87 | (let ((system (find-system system-name))) 88 | (cond (system 89 | (ql-dist:uninstall system)) 90 | (t 91 | (warn "Unknown system ~S" system-name) 92 | nil)))) 93 | 94 | (defun uninstall-dist (name) 95 | (let ((dist (find-dist name))) 96 | (when dist 97 | (ql-dist:uninstall dist)))) 98 | 99 | (defun write-asdf-manifest-file (output-file &key (if-exists :rename-and-delete) 100 | exclude-local-projects) 101 | "Write a list of system file pathnames to OUTPUT-FILE, one per line, 102 | in order of descending QL-DIST:PREFERENCE." 103 | (when (or (null output-file) 104 | (eql output-file t)) 105 | (setf output-file (qmerge "manifest.txt"))) 106 | (with-open-file (stream output-file 107 | :direction :output 108 | :if-exists if-exists) 109 | (unless exclude-local-projects 110 | (register-local-projects) 111 | (dolist (system-file (list-local-projects)) 112 | (let* ((enough (enough-namestring system-file output-file)) 113 | (native (native-namestring enough))) 114 | (write-line native stream)))) 115 | (with-consistent-dists 116 | (let ((systems (provided-systems t)) 117 | (already-seen (make-hash-table :test 'equal))) 118 | (dolist (system (sort systems #'> 119 | :key #'preference)) 120 | ;; FIXME: find-asdf-system-file does another find-system 121 | ;; behind the scenes. Bogus. Should be a better way to go 122 | ;; from system object to system file. 123 | (let* ((system-file (find-asdf-system-file (name system))) 124 | (enough (and system-file (enough-namestring system-file 125 | output-file))) 126 | (native (and enough (native-namestring enough)))) 127 | (when (and native (not (gethash native already-seen))) 128 | (setf (gethash native already-seen) native) 129 | (format stream "~A~%" native))))))) 130 | (probe-file output-file)) 131 | 132 | (defun where-is-system (name) 133 | "Return the pathname to the source directory of ASDF system with the 134 | given NAME, or NIL if no system by that name can be found known." 135 | (let ((system (asdf:find-system name nil))) 136 | (when system 137 | (asdf:system-source-directory system)))) 138 | -------------------------------------------------------------------------------- /quicklisp/config.lisp: -------------------------------------------------------------------------------- 1 | ;;;; config.lisp 2 | 3 | (in-package #:ql-config) 4 | 5 | (defun config-value-file-pathname (path) 6 | (let ((bad-position (position #\Space path))) 7 | (when bad-position 8 | (error "Space not allowed at position ~D in ~S" 9 | bad-position 10 | path))) 11 | (let* ((space-path (substitute #\Space #\/ path)) 12 | (split (split-spaces space-path)) 13 | (directory-parts (butlast split)) 14 | (name (first (last split))) 15 | (base (qmerge "config/"))) 16 | (merge-pathnames 17 | (make-pathname :name name 18 | :type "txt" 19 | :directory (list* :relative directory-parts)) 20 | base))) 21 | 22 | (defun config-value (path) 23 | (let ((file (config-value-file-pathname path))) 24 | (with-open-file (stream file :if-does-not-exist nil) 25 | (when stream 26 | (values (read-line stream nil)))))) 27 | 28 | (defun (setf config-value) (new-value path) 29 | (let ((file (config-value-file-pathname path))) 30 | (typecase new-value 31 | (null 32 | (delete-file-if-exists file)) 33 | (string 34 | (ensure-directories-exist file) 35 | (with-open-file (stream file :direction :output 36 | :if-does-not-exist :create 37 | :if-exists :rename-and-delete) 38 | (write-line new-value stream))) 39 | (t 40 | (error "Bad config value ~S; must be a string or NIL" new-value))))) 41 | -------------------------------------------------------------------------------- /quicklisp/deflate.lisp: -------------------------------------------------------------------------------- 1 | ;;;; Deflate --- RFC 1951 Deflate Decompression 2 | ;;;; 3 | ;;;; Copyright (C) 2000-2009 PMSF IT Consulting Pierre R. Mai. 4 | ;;;; 5 | ;;;; Permission is hereby granted, free of charge, to any person obtaining 6 | ;;;; a copy of this software and associated documentation files (the 7 | ;;;; "Software"), to deal in the Software without restriction, including 8 | ;;;; without limitation the rights to use, copy, modify, merge, publish, 9 | ;;;; distribute, sublicense, and/or sell copies of the Software, and to 10 | ;;;; permit persons to whom the Software is furnished to do so, subject to 11 | ;;;; the following conditions: 12 | ;;;; 13 | ;;;; The above copyright notice and this permission notice shall be 14 | ;;;; included in all copies or substantial portions of the Software. 15 | ;;;; 16 | ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | ;;;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | ;;;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ;;;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | ;;;; OTHER DEALINGS IN THE SOFTWARE. 23 | ;;;; 24 | ;;;; Except as contained in this notice, the name of the author shall 25 | ;;;; not be used in advertising or otherwise to promote the sale, use or 26 | ;;;; other dealings in this Software without prior written authorization 27 | ;;;; from the author. 28 | ;;;; 29 | ;;;; $Id: 377d3a33e9db5a3b54c850619183ee555a41b894 $ 30 | 31 | (cl:in-package #:ql-gunzipper) 32 | 33 | ;;;; %File Description: 34 | ;;;; 35 | ;;;; This file contains routines implementing the RFC 1951 Deflate 36 | ;;;; Compression and/or Decompression method, as used by e.g. gzip and 37 | ;;;; other compression and archiving tools and protocols. It also 38 | ;;;; implements handling routines for zlib-style (RFC 1950) and 39 | ;;;; gzip-style (RFC 1952) wrappers around raw Deflate streams. 40 | ;;;; 41 | ;;;; The main entry points are the functions inflate-stream, and its 42 | ;;;; cousins inflate-zlib-stream and inflate-gzip-stream, which take 43 | ;;;; an input-stream and an output-stream as their arguments, and 44 | ;;;; inflate the RFC 1951, RFC 1950 or RFC 1952-style deflate formats 45 | ;;;; from the input-stream to the output-stream. 46 | ;;;; 47 | 48 | ;;; 49 | ;;; Conditions 50 | ;;; 51 | 52 | (define-condition decompression-error (simple-error) 53 | ()) 54 | 55 | (define-condition deflate-decompression-error (decompression-error) 56 | () 57 | (:report 58 | (lambda (c s) 59 | (with-standard-io-syntax 60 | (let ((*print-readably* nil)) 61 | (format s 62 | "Error detected during deflate decompression: ~?" 63 | (simple-condition-format-control c) 64 | (simple-condition-format-arguments c))))))) 65 | 66 | (define-condition zlib-decompression-error (decompression-error) 67 | () 68 | (:report 69 | (lambda (c s) 70 | (with-standard-io-syntax 71 | (let ((*print-readably* nil)) 72 | (format s 73 | "Error detected during zlib decompression: ~?" 74 | (simple-condition-format-control c) 75 | (simple-condition-format-arguments c))))))) 76 | 77 | (define-condition gzip-decompression-error (decompression-error) 78 | () 79 | (:report 80 | (lambda (c s) 81 | (with-standard-io-syntax 82 | (let ((*print-readably* nil)) 83 | (format s 84 | "Error detected during zlib decompression: ~?" 85 | (simple-condition-format-control c) 86 | (simple-condition-format-arguments c))))))) 87 | 88 | ;;; 89 | ;;; Adler-32 Checksums 90 | ;;; 91 | 92 | (defconstant +adler-32-start-value+ 1 93 | "Start value for Adler-32 checksums as per RFC 1950.") 94 | 95 | (defconstant +adler-32-base+ 65521 96 | "Base value for Adler-32 checksums as per RFC 1950.") 97 | 98 | (declaim (ftype 99 | (function ((unsigned-byte 32) (simple-array (unsigned-byte 8) (*)) fixnum) 100 | (unsigned-byte 32)) 101 | update-adler32-checksum)) 102 | (defun update-adler32-checksum (crc buffer end) 103 | (declare (type (unsigned-byte 32) crc) 104 | (type (simple-array (unsigned-byte 8) (*)) buffer) 105 | (type fixnum end) 106 | (optimize (speed 3) (debug 0) (space 0) (safety 0)) 107 | #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) 108 | (let ((s1 (ldb (byte 16 0) crc)) 109 | (s2 (ldb (byte 16 16) crc))) 110 | (declare (type (unsigned-byte 32) s1 s2)) 111 | (dotimes (i end) 112 | (declare (type fixnum i)) 113 | (setq s1 (mod (+ s1 (aref buffer i)) +adler-32-base+) 114 | s2 (mod (+ s2 s1) +adler-32-base+))) 115 | (dpb s2 (byte 16 16) s1))) 116 | 117 | ;;; 118 | ;;; CRC-32 Checksums 119 | ;;; 120 | 121 | (defconstant +crc-32-start-value+ 0 122 | "Start value for CRC-32 checksums as per RFC 1952.") 123 | 124 | (eval-when (:compile-toplevel :load-toplevel :execute) 125 | (defconstant +crc-32-polynomial+ #xedb88320 126 | "CRC-32 Polynomial as per RFC 1952.")) 127 | 128 | (declaim (ftype #-lispworks (function () (simple-array (unsigned-byte 32) (256))) 129 | #+lispworks (function () (sys:simple-int32-vector 256)) 130 | generate-crc32-table)) 131 | (eval-when (:compile-toplevel :load-toplevel :execute) 132 | (defun generate-crc32-table () 133 | (let ((result #-lispworks (make-array 256 :element-type '(unsigned-byte 32)) 134 | #+lispworks (sys:make-simple-int32-vector 256))) 135 | (dotimes (i #-lispworks (length result) #+lispworks 256 result) 136 | (let ((cur i)) 137 | (dotimes (k 8) 138 | (setq cur (if (= 1 (logand cur 1)) 139 | (logxor (ash cur -1) +crc-32-polynomial+) 140 | (ash cur -1)))) 141 | #-lispworks (setf (aref result i) cur) 142 | #+lispworks (setf (sys:int32-aref result i) 143 | (sys:integer-to-int32 144 | (dpb (ldb (byte 32 0) cur) (byte 32 0) 145 | (if (logbitp 31 cur) -1 0))))))))) 146 | 147 | (declaim (ftype 148 | (function ((unsigned-byte 32) (simple-array (unsigned-byte 8) (*)) fixnum) 149 | (unsigned-byte 32)) 150 | update-crc32-checksum)) 151 | #-lispworks 152 | (defun update-crc32-checksum (crc buffer end) 153 | (declare (type (unsigned-byte 32) crc) 154 | (type (simple-array (unsigned-byte 8) (*)) buffer) 155 | (type fixnum end) 156 | (optimize (speed 3) (debug 0) (space 0) (safety 0)) 157 | #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) 158 | (let ((table #.(generate-crc32-table)) 159 | (cur (logxor crc #xffffffff))) 160 | (declare (type (simple-array (unsigned-byte 32) (256)) table) 161 | (type (unsigned-byte 32) cur)) 162 | (dotimes (i end) 163 | (declare (type fixnum i)) 164 | (let ((index (logand #xff (logxor cur (aref buffer i))))) 165 | (declare (type (unsigned-byte 8) index)) 166 | (setq cur (logxor (aref table index) (ash cur -8))))) 167 | (logxor cur #xffffffff))) 168 | 169 | #+lispworks 170 | (defun update-crc32-checksum (crc buffer end) 171 | (declare (type (unsigned-byte 32) crc) 172 | (type (simple-array (unsigned-byte 8) (*)) buffer) 173 | (type fixnum end) 174 | (optimize (speed 3) (debug 0) (space 0) (safety 0) (float 0))) 175 | (let ((table #.(generate-crc32-table)) 176 | (cur (sys:int32-lognot (sys:integer-to-int32 177 | (dpb (ldb (byte 32 0) crc) (byte 32 0) 178 | (if (logbitp 31 crc) -1 0)))))) 179 | (declare (type (sys:simple-int32-vector 256) table) 180 | (type sys:int32 cur)) 181 | (dotimes (i end) 182 | (declare (type fixnum i)) 183 | (let ((index (sys:int32-to-integer 184 | (sys:int32-logand #xff (sys:int32-logxor cur (aref buffer i)))))) 185 | (declare (type fixnum index)) 186 | (setq cur (sys:int32-logxor (sys:int32-aref table index) 187 | (sys:int32-logand #x00ffffff 188 | (sys:int32>> cur 8)))))) 189 | (ldb (byte 32 0) (sys:int32-to-integer (sys:int32-lognot cur))))) 190 | 191 | ;;; 192 | ;;; Helper Data Structures: Sliding Window Stream 193 | ;;; 194 | 195 | (eval-when (:compile-toplevel :load-toplevel :execute) 196 | (defconstant +sliding-window-size+ 32768 197 | "Size of sliding window for RFC 1951 Deflate compression scheme.")) 198 | 199 | (defstruct sliding-window-stream 200 | (stream nil :type stream :read-only t) 201 | (buffer (make-array +sliding-window-size+ :element-type '(unsigned-byte 8)) 202 | :type (simple-array (unsigned-byte 8) (#.+sliding-window-size+)) :read-only t) 203 | (buffer-end 0 :type fixnum) 204 | (checksum nil :type symbol :read-only t) 205 | (checksum-value 0 :type (unsigned-byte 32))) 206 | 207 | (declaim (inline sliding-window-stream-write-byte)) 208 | (defun sliding-window-stream-write-byte (stream byte) 209 | (declare (type sliding-window-stream stream) (type (unsigned-byte 8) byte) 210 | #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) 211 | "Write a single byte to the sliding-window-stream." 212 | (let ((end (sliding-window-stream-buffer-end stream))) 213 | (declare (type fixnum end)) 214 | (unless (< end +sliding-window-size+) 215 | (write-sequence (sliding-window-stream-buffer stream) 216 | (sliding-window-stream-stream stream)) 217 | (case (sliding-window-stream-checksum stream) 218 | (:adler-32 (setf (sliding-window-stream-checksum-value stream) 219 | (update-adler32-checksum 220 | (sliding-window-stream-checksum-value stream) 221 | (sliding-window-stream-buffer stream) 222 | +sliding-window-size+))) 223 | (:crc-32 (setf (sliding-window-stream-checksum-value stream) 224 | (update-crc32-checksum 225 | (sliding-window-stream-checksum-value stream) 226 | (sliding-window-stream-buffer stream) 227 | +sliding-window-size+)))) 228 | (setq end 0)) 229 | (setf (aref (sliding-window-stream-buffer stream) end) byte 230 | (sliding-window-stream-buffer-end stream) (1+ end)))) 231 | 232 | (defun sliding-window-stream-flush (stream) 233 | (declare (type sliding-window-stream stream)) 234 | "Flush any remaining buffered bytes from the stream." 235 | (let ((end (sliding-window-stream-buffer-end stream))) 236 | (declare (type fixnum end)) 237 | (unless (zerop end) 238 | (case (sliding-window-stream-checksum stream) 239 | (:adler-32 (setf (sliding-window-stream-checksum-value stream) 240 | (update-adler32-checksum 241 | (sliding-window-stream-checksum-value stream) 242 | (sliding-window-stream-buffer stream) 243 | end))) 244 | (:crc-32 (setf (sliding-window-stream-checksum-value stream) 245 | (update-crc32-checksum 246 | (sliding-window-stream-checksum-value stream) 247 | (sliding-window-stream-buffer stream) 248 | end)))) 249 | (write-sequence (sliding-window-stream-buffer stream) 250 | (sliding-window-stream-stream stream) 251 | :end end)))) 252 | 253 | (defun sliding-window-stream-copy-bytes (stream distance length) 254 | (declare (type sliding-window-stream stream) (type fixnum distance length)) 255 | "Copy a number of bytes from the current sliding window." 256 | (let* ((end (sliding-window-stream-buffer-end stream)) 257 | (start (mod (- end distance) +sliding-window-size+)) 258 | (buffer (sliding-window-stream-buffer stream))) 259 | (declare (type fixnum end start) 260 | (type (simple-array (unsigned-byte 8) (#.+sliding-window-size+)) buffer)) 261 | (dotimes (i length) 262 | (sliding-window-stream-write-byte 263 | stream 264 | (aref buffer (mod (+ start i) +sliding-window-size+)))))) 265 | 266 | ;;; 267 | ;;; Helper Data Structures: Bit-wise Input Stream 268 | ;;; 269 | 270 | (defstruct bit-stream 271 | (stream nil :type stream :read-only t) 272 | (next-byte 0 :type fixnum) 273 | (bits 0 :type (unsigned-byte 29)) 274 | (bit-count 0 :type (unsigned-byte 8))) 275 | 276 | (declaim (inline bit-stream-get-byte)) 277 | (defun bit-stream-get-byte (stream) 278 | (declare (type bit-stream stream)) 279 | "Read another byte from the underlying stream." 280 | (the (unsigned-byte 8) (read-byte (bit-stream-stream stream)))) 281 | 282 | (declaim (inline bit-stream-read-bits)) 283 | (defun bit-stream-read-bits (stream bits) 284 | (declare (type bit-stream stream) 285 | ;; [quicklisp-added] 286 | ;; FIXME: This might be fixed soon in ECL. 287 | ;; http://article.gmane.org/gmane.lisp.ecl.general/7659 288 | #-ecl 289 | (type (unsigned-byte 8) bits)) 290 | "Read single or multiple bits from the given bit-stream." 291 | (loop while (< (bit-stream-bit-count stream) bits) 292 | do 293 | ;; Fill bits 294 | (setf (bit-stream-bits stream) 295 | (logior (bit-stream-bits stream) 296 | (the (unsigned-byte 29) 297 | (ash (bit-stream-get-byte stream) 298 | (bit-stream-bit-count stream)))) 299 | (bit-stream-bit-count stream) (+ (bit-stream-bit-count stream) 8))) 300 | ;; Return properly masked bits 301 | (if (= (bit-stream-bit-count stream) bits) 302 | (prog1 (bit-stream-bits stream) 303 | (setf (bit-stream-bits stream) 0 304 | (bit-stream-bit-count stream) 0)) 305 | (prog1 (ldb (byte bits 0) (bit-stream-bits stream)) 306 | (setf (bit-stream-bits stream) (ash (bit-stream-bits stream) (- bits)) 307 | (bit-stream-bit-count stream) (- (bit-stream-bit-count stream) bits))))) 308 | 309 | (declaim (inline bit-stream-copy-block)) 310 | (defun bit-stream-copy-block (stream out-stream) 311 | (declare (type bit-stream stream) (type sliding-window-stream out-stream) 312 | (optimize (speed 3) (safety 0) (space 0) (debug 0))) 313 | "Copy a given block of bytes directly from the underlying stream." 314 | ;; Skip any remaining unprocessed bits 315 | (setf (bit-stream-bits stream) 0 316 | (bit-stream-bit-count stream) 0) 317 | ;; Get LEN/NLEN and copy bytes 318 | (let* ((len (logior (bit-stream-get-byte stream) 319 | (ash (bit-stream-get-byte stream) 8))) 320 | (nlen (ldb (byte 16 0) 321 | (lognot (logior (bit-stream-get-byte stream) 322 | (ash (bit-stream-get-byte stream) 8)))))) 323 | (unless (= len nlen) 324 | (error 'deflate-decompression-error 325 | :format-control 326 | "Block length mismatch for stored block: LEN(~D) vs. NLEN(~D)!" 327 | :format-arguments (list len nlen))) 328 | (dotimes (i len) 329 | (sliding-window-stream-write-byte out-stream (bit-stream-get-byte stream))))) 330 | 331 | ;;; 332 | ;;; Huffman Coding 333 | ;;; 334 | 335 | ;;; A decode-tree struct contains all information necessary to decode 336 | ;;; the given canonical huffman code. Note that length-count contains 337 | ;;; the number of codes with a given length for each length, whereas 338 | ;;; the code-symbols array contains the symbols corresponding to the 339 | ;;; codes in canoical order of the codes. 340 | ;;; 341 | ;;; Decoding then uses this information and the principles underlying 342 | ;;; canonical huffman codes to determine whether the currently 343 | ;;; collected word falls between the first code and the last code for 344 | ;;; the current length, and if so, uses the offset to determine the 345 | ;;; code's symbol. Otherwise more bits are needed. 346 | 347 | (defstruct decode-tree 348 | (length-count (make-array 16 :element-type 'fixnum :initial-element 0) 349 | :type (simple-array fixnum (*)) :read-only t) 350 | (code-symbols (make-array 16 :element-type 'fixnum :initial-element 0) 351 | :type (simple-array fixnum (*)))) 352 | 353 | (defun make-huffman-decode-tree (code-lengths) 354 | "Construct a huffman decode-tree for the canonical huffman code with 355 | the code lengths of each symbol given in the input array." 356 | (let* ((max-length (reduce #'max code-lengths :initial-value 0)) 357 | (next-code (make-array (1+ max-length) :element-type 'fixnum 358 | :initial-element 0)) 359 | (code-symbols (make-array (length code-lengths) :element-type 'fixnum 360 | :initial-element 0)) 361 | (length-count (make-array (1+ max-length) :element-type 'fixnum 362 | :initial-element 0))) 363 | ;; Count length occurences and calculate offsets of smallest codes 364 | (loop for index from 1 to max-length 365 | for code = 0 then (+ code (aref length-count (1- index))) 366 | do 367 | (setf (aref next-code index) code) 368 | initially 369 | ;; Count length occurences 370 | (loop for length across code-lengths 371 | do 372 | (incf (aref length-count length)) 373 | finally 374 | (setf (aref length-count 0) 0))) 375 | ;; Construct code symbols mapping 376 | (loop for length across code-lengths 377 | for index upfrom 0 378 | unless (zerop length) 379 | do 380 | (setf (aref code-symbols (aref next-code length)) index) 381 | (incf (aref next-code length))) 382 | ;; Return result 383 | (make-decode-tree :length-count length-count :code-symbols code-symbols))) 384 | 385 | (declaim (inline read-huffman-code)) 386 | (defun read-huffman-code (bit-stream decode-tree) 387 | (declare (type bit-stream bit-stream) (type decode-tree decode-tree) 388 | (optimize (speed 3) (safety 0) (space 0) (debug 0))) 389 | "Read the next huffman code word from the given bit-stream and 390 | return its decoded symbol, for the huffman code given by decode-tree." 391 | (loop with length-count of-type (simple-array fixnum (*)) 392 | = (decode-tree-length-count decode-tree) 393 | with code-symbols of-type (simple-array fixnum (*)) 394 | = (decode-tree-code-symbols decode-tree) 395 | for code of-type fixnum = (bit-stream-read-bits bit-stream 1) 396 | then (+ (* code 2) (bit-stream-read-bits bit-stream 1)) 397 | for index of-type fixnum = 0 then (+ index count) 398 | for first of-type fixnum = 0 then (* (+ first count) 2) 399 | for length of-type fixnum upfrom 1 below (length length-count) 400 | for count = (aref length-count length) 401 | thereis (when (< code (the fixnum (+ first count))) 402 | (aref code-symbols (+ index (- code first)))) 403 | finally 404 | (error 'deflate-decompression-error 405 | :format-control 406 | "Corrupted Data detected during decompression: ~ 407 | Incorrect huffman code (~X) in huffman decode!" 408 | :format-arguments (list code)))) 409 | 410 | ;;; 411 | ;;; Standard Huffman Tables 412 | ;;; 413 | 414 | (defparameter *std-lit-decode-tree* 415 | (make-huffman-decode-tree 416 | (concatenate 'vector 417 | (make-sequence 'vector 144 :initial-element 8) 418 | (make-sequence 'vector 112 :initial-element 9) 419 | (make-sequence 'vector 24 :initial-element 7) 420 | (make-sequence 'vector 8 :initial-element 8)))) 421 | 422 | (defparameter *std-dist-decode-tree* 423 | (make-huffman-decode-tree 424 | (make-sequence 'vector 32 :initial-element 5))) 425 | 426 | ;;; 427 | ;;; Dynamic Huffman Table Handling 428 | ;;; 429 | 430 | (defparameter *code-length-entry-order* 431 | #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15) 432 | "Order of Code Length Tree Code Lengths.") 433 | 434 | (defun decode-code-length-entries (bit-stream count decode-tree) 435 | "Decode the given number of code length entries from the bit-stream 436 | using the given decode-tree, and return a corresponding array of code 437 | lengths for further processing." 438 | (do ((result (make-array count :element-type 'fixnum :initial-element 0)) 439 | (index 0)) 440 | ((>= index count) result) 441 | (let ((code (read-huffman-code bit-stream decode-tree))) 442 | (ecase code 443 | ((0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) 444 | (setf (aref result index) code) 445 | (incf index)) 446 | (16 447 | (let ((length (+ 3 (bit-stream-read-bits bit-stream 2)))) 448 | (dotimes (i length) 449 | (setf (aref result (+ index i)) (aref result (1- index)))) 450 | (incf index length))) 451 | (17 452 | (let ((length (+ 3 (bit-stream-read-bits bit-stream 3)))) 453 | (dotimes (i length) 454 | (setf (aref result (+ index i)) 0)) 455 | (incf index length))) 456 | (18 457 | (let ((length (+ 11 (bit-stream-read-bits bit-stream 7)))) 458 | (dotimes (i length) 459 | (setf (aref result (+ index i)) 0)) 460 | (incf index length))))))) 461 | 462 | (defun decode-huffman-tables (bit-stream) 463 | "Decode the stored huffman tables from the given bit-stream, returning 464 | the corresponding decode-trees for literals/length and distance codes." 465 | (let* ((hlit (bit-stream-read-bits bit-stream 5)) 466 | (hdist (bit-stream-read-bits bit-stream 5)) 467 | (hclen (bit-stream-read-bits bit-stream 4))) 468 | ;; Construct Code Length Decode Tree 469 | (let ((cl-decode-tree 470 | (loop with code-lengths = (make-array 19 :element-type '(unsigned-byte 8) 471 | :initial-element 0) 472 | for index from 0 below (+ hclen 4) 473 | for code-length = (bit-stream-read-bits bit-stream 3) 474 | for code-index = (aref *code-length-entry-order* index) 475 | do 476 | (setf (aref code-lengths code-index) code-length) 477 | finally 478 | (return (make-huffman-decode-tree code-lengths))))) 479 | ;; Decode Code Length Table and generate separate huffman trees 480 | (let ((entries (decode-code-length-entries bit-stream 481 | (+ hlit 257 hdist 1) 482 | cl-decode-tree))) 483 | (values 484 | (make-huffman-decode-tree (subseq entries 0 (+ hlit 257))) 485 | (make-huffman-decode-tree (subseq entries (+ hlit 257)))))))) 486 | 487 | ;;; 488 | ;;; Compressed Block Handling 489 | ;;; 490 | 491 | (declaim (inline decode-length-entry)) 492 | (defun decode-length-entry (symbol bit-stream) 493 | "Decode the given length symbol into a proper length specification." 494 | (cond 495 | ((<= symbol 264) (- symbol 254)) 496 | ((<= symbol 268) (+ 11 (* (- symbol 265) 2) (bit-stream-read-bits bit-stream 1))) 497 | ((<= symbol 272) (+ 19 (* (- symbol 269) 4) (bit-stream-read-bits bit-stream 2))) 498 | ((<= symbol 276) (+ 35 (* (- symbol 273) 8) (bit-stream-read-bits bit-stream 3))) 499 | ((<= symbol 280) (+ 67 (* (- symbol 277) 16) (bit-stream-read-bits bit-stream 4))) 500 | ((<= symbol 284) 501 | (+ 131 (* (- symbol 281) 32) (bit-stream-read-bits bit-stream 5))) 502 | ((= symbol 285) 258) 503 | (t 504 | (error 'deflate-decompression-error 505 | :format-control "Strange Length Code in bitstream: ~D" 506 | :format-arguments (list symbol))))) 507 | 508 | (declaim (inline decode-distance-entry)) 509 | (defun decode-distance-entry (symbol bit-stream) 510 | "Decode the given distance symbol into a proper distance specification." 511 | (cond 512 | ((<= symbol 3) (1+ symbol)) 513 | (t 514 | (multiple-value-bind (order offset) (truncate symbol 2) 515 | (let* ((extra-bits (1- order)) 516 | (factor (ash 1 extra-bits))) 517 | (+ (1+ (ash 1 order)) 518 | (* offset factor) 519 | (bit-stream-read-bits bit-stream extra-bits))))))) 520 | 521 | (defun decode-huffman-block (bit-stream window-stream 522 | lit-decode-tree dist-decode-tree) 523 | "Decode the huffman code block using the huffman codes given by 524 | lit-decode-tree and dist-decode-tree." 525 | (do ((symbol (read-huffman-code bit-stream lit-decode-tree) 526 | (read-huffman-code bit-stream lit-decode-tree))) 527 | ((= symbol 256)) 528 | (cond 529 | ((<= symbol 255) 530 | (sliding-window-stream-write-byte window-stream symbol)) 531 | (t 532 | (let ((length (decode-length-entry symbol bit-stream)) 533 | (distance (decode-distance-entry 534 | (read-huffman-code bit-stream dist-decode-tree) bit-stream))) 535 | (sliding-window-stream-copy-bytes window-stream distance length)))))) 536 | 537 | ;;; 538 | ;;; Block Handling Code 539 | ;;; 540 | 541 | (defun decode-block (bit-stream window-stream) 542 | "Decompress a block read from bit-stream into window-stream." 543 | (let* ((finalp (not (zerop (bit-stream-read-bits bit-stream 1)))) 544 | (type (bit-stream-read-bits bit-stream 2))) 545 | (ecase type 546 | (#b00 (bit-stream-copy-block bit-stream window-stream)) 547 | (#b01 548 | (decode-huffman-block bit-stream window-stream 549 | *std-lit-decode-tree* 550 | *std-dist-decode-tree*)) 551 | (#b10 552 | (multiple-value-bind (lit-decode-tree dist-decode-tree) 553 | (decode-huffman-tables bit-stream) 554 | (decode-huffman-block bit-stream window-stream 555 | lit-decode-tree dist-decode-tree))) 556 | (#b11 557 | (error 'deflate-decompression-error 558 | :format-control "Encountered Reserved Block Type ~D!" 559 | :format-arguments (list type)))) 560 | (not finalp))) 561 | 562 | ;;; 563 | ;;; ZLIB - RFC 1950 handling 564 | ;;; 565 | 566 | (defun parse-zlib-header (input-stream) 567 | "Parse a ZLIB-style header as per RFC 1950 from the input-stream and 568 | return the compression-method, compression-level dictionary-id and flags 569 | fields of the header as return values. Checks the header for corruption 570 | and signals a zlib-decompression-error in case of corruption." 571 | (let ((compression-method (read-byte input-stream)) 572 | (flags (read-byte input-stream))) 573 | (unless (zerop (mod (+ (* compression-method 256) flags) 31)) 574 | (error 'zlib-decompression-error 575 | :format-control "Corrupted Header ~2,'0X,~2,'0X!" 576 | :format-arguments (list compression-method flags))) 577 | (let ((dict (unless (zerop (ldb (byte 1 5) flags)) 578 | (parse-zlib-checksum input-stream)))) 579 | (values (ldb (byte 4 0) compression-method) 580 | (ldb (byte 4 4) compression-method) 581 | dict 582 | (ldb (byte 2 6) flags))))) 583 | 584 | (defun parse-zlib-checksum (input-stream) 585 | (+ (* (read-byte input-stream) 256 256 256) 586 | (* (read-byte input-stream) 256 256) 587 | (* (read-byte input-stream) 256) 588 | (read-byte input-stream))) 589 | 590 | (defun parse-zlib-footer (input-stream) 591 | "Parse the ZLIB-style footer as per RFC 1950 from the input-stream and 592 | return the Adler-32 checksum contained in the footer as its return value." 593 | (parse-zlib-checksum input-stream)) 594 | 595 | ;;; 596 | ;;; GZIP - RFC 1952 handling 597 | ;;; 598 | 599 | (defconstant +gzip-header-id1+ 31 600 | "GZIP Header Magic Value ID1 as per RFC 1952.") 601 | 602 | (defconstant +gzip-header-id2+ 139 603 | "GZIP Header Magic Value ID2 as per RFC 1952.") 604 | 605 | (defun parse-gzip-header (input-stream) 606 | "Parse a GZIP-style header as per RFC 1952 from the input-stream and 607 | return the compression-method, text-flag, modification time, XFLAGS, 608 | OS, FEXTRA flags, filename, comment and CRC16 fields of the header as 609 | return values (or nil if any given field is not present). Checks the 610 | header for magic values and correct flags settings and signals a 611 | gzip-decompression-error in case of incorrect or unsupported magic 612 | values or flags." 613 | (let ((id1 (read-byte input-stream)) 614 | (id2 (read-byte input-stream)) 615 | (compression-method (read-byte input-stream)) 616 | (flags (read-byte input-stream))) 617 | (unless (and (= id1 +gzip-header-id1+) (= id2 +gzip-header-id2+)) 618 | (error 'gzip-decompression-error 619 | :format-control 620 | "Header missing magic values ~2,'0X,~2,'0X (got ~2,'0X,~2,'0X instead)!" 621 | :format-arguments (list +gzip-header-id1+ +gzip-header-id2+ id1 id2))) 622 | (unless (= compression-method 8) 623 | (error 'gzip-decompression-error 624 | :format-control "Unknown compression-method in Header ~2,'0X!" 625 | :format-arguments (list compression-method))) 626 | (unless (zerop (ldb (byte 3 5) flags)) 627 | (error 'gzip-decompression-error 628 | :format-control "Unknown flags in Header ~2,'0X!" 629 | :format-arguments (list flags))) 630 | (values compression-method 631 | ;; FTEXT 632 | (= 1 (ldb (byte 1 0) flags)) 633 | ;; MTIME 634 | (parse-gzip-mtime input-stream) 635 | ;; XFLAGS 636 | (read-byte input-stream) 637 | ;; OS 638 | (read-byte input-stream) 639 | ;; FEXTRA 640 | (unless (zerop (ldb (byte 1 2) flags)) 641 | (parse-gzip-extra input-stream)) 642 | ;; FNAME 643 | (unless (zerop (ldb (byte 1 3) flags)) 644 | (parse-gzip-string input-stream)) 645 | ;; FCOMMENT 646 | (unless (zerop (ldb (byte 1 4) flags)) 647 | (parse-gzip-string input-stream)) 648 | ;; CRC16 649 | (unless (zerop (ldb (byte 1 1) flags)) 650 | (+ (read-byte input-stream) 651 | (* (read-byte input-stream 256))))))) 652 | 653 | (defun parse-gzip-mtime (input-stream) 654 | (let ((time (+ (read-byte input-stream) 655 | (* (read-byte input-stream) 256) 656 | (* (read-byte input-stream) 256 256) 657 | (* (read-byte input-stream) 256 256 256)))) 658 | (if (zerop time) 659 | nil 660 | (+ time 2208988800)))) 661 | 662 | (defun parse-gzip-extra (input-stream) 663 | (let* ((length (+ (read-byte input-stream) (* (read-byte input-stream) 256))) 664 | (result (make-array length :element-type '(unsigned-byte 8)))) 665 | (read-sequence result input-stream) 666 | result)) 667 | 668 | (defun parse-gzip-string (input-stream) 669 | (with-output-to-string (string) 670 | (loop for value = (read-byte input-stream) 671 | until (zerop value) 672 | do (write-char (code-char value) string)))) 673 | 674 | (defun parse-gzip-checksum (input-stream) 675 | (+ (read-byte input-stream) 676 | (* (read-byte input-stream) 256) 677 | (* (read-byte input-stream) 256 256) 678 | (* (read-byte input-stream) 256 256 256))) 679 | 680 | (defun parse-gzip-footer (input-stream) 681 | "Parse the GZIP-style footer as per RFC 1952 from the input-stream and 682 | return the CRC-32 checksum and ISIZE fields contained in the footer as 683 | its return values." 684 | (values (parse-gzip-checksum input-stream) 685 | ;; ISIZE 686 | (+ (read-byte input-stream) 687 | (* (read-byte input-stream) 256) 688 | (* (read-byte input-stream) 256 256) 689 | (* (read-byte input-stream) 256 256 256)))) 690 | 691 | ;;; 692 | ;;; Main Entry Points 693 | ;;; 694 | 695 | (defun inflate-stream (input-stream output-stream &key checksum) 696 | "Inflate the RFC 1951 data from the given input stream into the 697 | given output stream, which are required to have an element-type 698 | of (unsigned-byte 8). If checksum is given, it indicates the 699 | checksumming algorithm to employ in calculating a checksum of 700 | the expanded content, which is then returned from this function. 701 | Valid values are :adler-32 for Adler-32 checksum (see RFC 1950), 702 | or :crc-32 for CRC-32 as per ISO 3309 (see RFC 1952, ZIP)." 703 | (loop with window-stream = (make-sliding-window-stream :stream output-stream 704 | :checksum checksum 705 | :checksum-value 706 | (ecase checksum 707 | ((nil) 0) 708 | (:crc-32 +crc-32-start-value+) 709 | (:adler-32 +adler-32-start-value+))) 710 | with bit-stream = (make-bit-stream :stream input-stream) 711 | while (decode-block bit-stream window-stream) 712 | finally (sliding-window-stream-flush window-stream) 713 | (when checksum 714 | (return (sliding-window-stream-checksum-value window-stream))))) 715 | 716 | (defun inflate-zlib-stream (input-stream output-stream &key check-checksum) 717 | "Inflate the RFC 1950 zlib data from the given input stream into 718 | the given output stream, which are required to have an element-type 719 | of (unsigned-byte 8). This returns the Adler-32 checksum of the 720 | file as its first return value, with the compression level as its 721 | second return value. Note that it is the responsibility of the 722 | caller to check whether the expanded data matches the Adler-32 723 | checksum, unless the check-checksum keyword argument is set to 724 | true, in which case the checksum is checked internally and a 725 | zlib-decompression-error is signalled if they don't match." 726 | (multiple-value-bind (cm cinfo dictid flevel) (parse-zlib-header input-stream) 727 | (unless (= cm 8) 728 | (error 'zlib-decompression-error 729 | :format-control "Unknown compression method ~D!" 730 | :format-arguments (list cm))) 731 | (unless (<= cinfo 7) 732 | (error 'zlib-decompression-error 733 | :format-control "Unsupported sliding window size 2^~D = ~D!" 734 | :format-arguments (list (+ 8 cinfo) (expt 2 (+ 8 cinfo))))) 735 | (unless (null dictid) 736 | (error 'zlib-decompression-error 737 | :format-control "Unknown preset dictionary id ~8,'0X!" 738 | :format-arguments (list dictid))) 739 | (let ((checksum-new (inflate-stream input-stream output-stream 740 | :checksum (when check-checksum :adler-32))) 741 | (checksum-old (parse-zlib-footer input-stream))) 742 | (when (and check-checksum (not (= checksum-old checksum-new))) 743 | (error 'zlib-decompression-error 744 | :format-control 745 | "Checksum mismatch for decompressed stream: ~8,'0X != ~8,'0X!" 746 | :format-arguments (list checksum-old checksum-new))) 747 | (values checksum-old flevel)))) 748 | 749 | (defun inflate-gzip-stream (input-stream output-stream &key check-checksum) 750 | "Inflate the RFC 1952 gzip data from the given input stream into 751 | the given output stream, which are required to have an element-type 752 | of (unsigned-byte 8). This returns the CRC-32 checksum of the 753 | file as its first return value, with any filename, modification time, 754 | and comment fields as further return values or nil if not present. 755 | Note that it is the responsibility of the caller to check whether the 756 | expanded data matches the CRC-32 checksum, unless the check-checksum 757 | keyword argument is set to true, in which case the checksum is checked 758 | internally and a gzip-decompression-error is signalled if they don't 759 | match." 760 | (multiple-value-bind (cm ftext mtime xfl os fextra fname fcomment) 761 | (parse-gzip-header input-stream) 762 | (declare (ignore ftext xfl os fextra)) 763 | (unless (= cm 8) 764 | (error 'gzip-decompression-error 765 | :format-control "Unknown compression method ~D!" 766 | :format-arguments (list cm))) 767 | (let ((checksum-new (inflate-stream input-stream output-stream 768 | :checksum (when check-checksum :crc-32))) 769 | (checksum-old (parse-gzip-footer input-stream))) 770 | ;; Handle Checksums 771 | (when (and check-checksum (not (= checksum-old checksum-new))) 772 | (error 'gzip-decompression-error 773 | :format-control 774 | "Checksum mismatch for decompressed stream: ~8,'0X != ~8,'0X!" 775 | :format-arguments (list checksum-old checksum-new))) 776 | (values checksum-old fname mtime fcomment)))) 777 | 778 | 779 | (defun gunzip (input-file output-file) 780 | (with-open-file (input input-file 781 | :element-type '(unsigned-byte 8)) 782 | (with-open-file (output output-file 783 | :direction :output 784 | :if-exists :supersede 785 | :element-type '(unsigned-byte 8)) 786 | (inflate-gzip-stream input output))) 787 | (probe-file output-file)) 788 | -------------------------------------------------------------------------------- /quicklisp/dist-update.lisp: -------------------------------------------------------------------------------- 1 | ;;;; dist-update.lisp 2 | 3 | (in-package #:ql-dist) 4 | 5 | (defgeneric available-update (dist) 6 | (:documentation "If an update is available for DIST, return the 7 | update as an uninstalled dist object. Otherwise, return NIL.")) 8 | 9 | (defgeneric update-release-differences (old-dist new-dist) 10 | (:documentation "Compare OLD-DIST to NEW-DIST and return three lists 11 | as multiple values: new releases \(present in NEW-DIST but not 12 | OLD-DIST), changed releases \(present in both dists but different in 13 | some way), and removed releases \(present in OLD-DIST but not 14 | NEW-DIST). The list of changed releases is a list of two-element 15 | lists, with each two-element list having first the old release 16 | object and then the new release object.")) 17 | 18 | (defgeneric show-update-report (old-dist new-dist) 19 | (:documentation "Display a description of the update from OLD-DIST 20 | to NEW-DIST.")) 21 | 22 | (defgeneric update-in-place (old-dist new-dist) 23 | (:documentation "Update OLD-DIST to NEW-DIST in place.")) 24 | 25 | (defmethod available-update ((dist dist)) 26 | (let ((url (distinfo-subscription-url dist)) 27 | (target (qmerge "tmp/distinfo-update/distinfo.txt")) 28 | (update-directory (qmerge "tmp/distinfo-update/"))) 29 | (when (probe-directory update-directory) 30 | (delete-directory-tree (qmerge "tmp/distinfo-update/"))) 31 | (when url 32 | (ensure-directories-exist target) 33 | (fetch url target :quietly t) 34 | (let ((new (make-dist-from-file target))) 35 | (setf (base-directory new) 36 | (make-pathname :name nil 37 | :type nil 38 | :version nil 39 | :defaults target)) 40 | (when (and (string= (name dist) (name new)) 41 | (string/= (version dist) (version new))) 42 | new))))) 43 | 44 | (defmethod update-release-differences ((old-dist dist) 45 | (new-dist dist)) 46 | (let ((old-releases (provided-releases old-dist)) 47 | (new-releases (provided-releases new-dist)) 48 | (new '()) 49 | (updated '()) 50 | (removed '()) 51 | (old-by-name (make-hash-table :test 'equalp))) 52 | (dolist (release old-releases) 53 | (setf (gethash (name release) old-by-name) 54 | release)) 55 | (dolist (new-release new-releases) 56 | (let* ((name (name new-release)) 57 | (old-release (gethash name old-by-name))) 58 | (remhash name old-by-name) 59 | (cond ((not old-release) 60 | (push new-release new)) 61 | ((not (equal (archive-content-sha1 new-release) 62 | (archive-content-sha1 old-release))) 63 | (push (list old-release new-release) updated))))) 64 | (maphash (lambda (name old-release) 65 | (declare (ignore name)) 66 | (push old-release removed)) 67 | old-by-name) 68 | (values (nreverse new) 69 | (nreverse updated) 70 | (sort removed #'string< :key #'prefix)))) 71 | 72 | (defmethod show-update-report ((old-dist dist) (new-dist dist)) 73 | (multiple-value-bind (new updated removed) 74 | (update-release-differences old-dist new-dist) 75 | (format t "Changes from ~A ~A to ~A ~A:~%" 76 | (name old-dist) 77 | (version old-dist) 78 | (name new-dist) 79 | (version new-dist)) 80 | (when new 81 | (format t "~& New projects:~%") 82 | (format t "~{ ~A~%~}" (mapcar #'prefix new))) 83 | (when updated 84 | (format t "~% Updated projects:~%") 85 | (loop for (old-release new-release) in updated 86 | do (format t " ~A -> ~A~%" 87 | (prefix old-release) 88 | (prefix new-release)))) 89 | (when removed 90 | (format t "~% Removed projects:~%") 91 | (format t "~{ ~A~%~}" (mapcar #'prefix removed))))) 92 | 93 | (defun clear-dist-systems (dist) 94 | (dolist (system (provided-systems dist)) 95 | (asdf:clear-system (name system)))) 96 | 97 | (defmethod update-in-place :before ((old-dist dist) (new-dist dist)) 98 | ;; Make sure ASDF will reload any systems at their new locations 99 | (clear-dist-systems old-dist)) 100 | 101 | (defmethod update-in-place :after ((old-dist dist) (new-dist dist)) 102 | (clean new-dist)) 103 | 104 | (defmethod update-in-place ((old-dist dist) (new-dist dist)) 105 | (flet ((remove-installed (type) 106 | (let ((wild (merge-pathnames (make-pathname :directory 107 | (list :relative 108 | "installed" 109 | type) 110 | :name :wild 111 | :type "txt") 112 | (base-directory old-dist)))) 113 | (dolist (file (directory wild)) 114 | (delete-file file))))) 115 | (let ((reinstall-releases (installed-releases old-dist))) 116 | (remove-installed "systems") 117 | (remove-installed "releases") 118 | (delete-file-if-exists (relative-to old-dist "releases.txt")) 119 | (delete-file-if-exists (relative-to old-dist "systems.txt")) 120 | (delete-file-if-exists (relative-to old-dist "releases.cdb")) 121 | (delete-file-if-exists (relative-to old-dist "systems.cdb")) 122 | (replace-file (local-distinfo-file new-dist) 123 | (local-distinfo-file old-dist)) 124 | (setf new-dist (find-dist (name new-dist))) 125 | (dolist (old-release reinstall-releases) 126 | (let* ((name (name old-release)) 127 | (new-release (find-release-in-dist name new-dist))) 128 | (if new-release 129 | (ensure-installed new-release) 130 | (warn "~S is not available in ~A" name new-dist))))))) 131 | 132 | (defun install-dist (url &key (prompt t) replace) 133 | (block nil 134 | (setf url (url url)) 135 | (let ((temp-file (qmerge "tmp/install-dist-distinfo.txt"))) 136 | (ensure-directories-exist temp-file) 137 | (delete-file-if-exists temp-file) 138 | (fetch url temp-file) 139 | (let* ((new-dist (make-dist-from-file temp-file)) 140 | (old-dist (find-dist (name new-dist)))) 141 | (when old-dist 142 | (if replace 143 | (uninstall old-dist) 144 | (restart-case 145 | (error "A dist named ~S is already installed." 146 | (name new-dist)) 147 | (replace () 148 | :report "Replace installed dist with new dist" 149 | (uninstall old-dist))))) 150 | (format t "Installing dist ~S version ~S.~%" 151 | (name new-dist) 152 | (version new-dist)) 153 | (when (or (not prompt) 154 | (press-enter-to-continue)) 155 | (ensure-directories-exist (base-directory new-dist)) 156 | (copy-file temp-file (relative-to new-dist "distinfo.txt")) 157 | (ensure-release-index-file new-dist) 158 | (ensure-system-index-file new-dist) 159 | (enable new-dist) 160 | (setf (preference new-dist) (get-universal-time)) 161 | (when old-dist 162 | (clear-dist-systems old-dist)) 163 | (clear-dist-systems new-dist) 164 | new-dist))))) 165 | -------------------------------------------------------------------------------- /quicklisp/fetch-gzipped.lisp: -------------------------------------------------------------------------------- 1 | ;;;; fetch-gzipped.lisp 2 | 3 | (in-package #:quicklisp-client) 4 | 5 | (defun gzipped-url (url) 6 | (check-type url string) 7 | (concatenate 'string url ".gz")) 8 | 9 | (defun fetch-gzipped-version (url file &key quietly) 10 | (let ((gzipped (gzipped-url url)) 11 | (gzipped-temp (merge-pathnames "gzipped.tmp" file))) 12 | (fetch gzipped gzipped-temp :quietly quietly) 13 | (gunzip gzipped-temp file) 14 | (delete-file-if-exists gzipped-temp) 15 | (probe-file file))) 16 | 17 | (defun url-not-suitable-error-p (condition) 18 | (<= 400 (unexpected-http-status-code condition) 499)) 19 | 20 | (defun maybe-fetch-gzipped (url file &key quietly) 21 | (handler-case 22 | (fetch-gzipped-version url file :quietly quietly) 23 | (unexpected-http-status (condition) 24 | (cond ((url-not-suitable-error-p condition) 25 | (fetch url file :quietly quietly) 26 | (probe-file file)) 27 | (t 28 | (error condition)))))) 29 | 30 | -------------------------------------------------------------------------------- /quicklisp/http.lisp: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; A simple HTTP client 3 | ;;; 4 | 5 | (in-package #:ql-http) 6 | 7 | ;;; Octet data 8 | 9 | (deftype octet () 10 | '(unsigned-byte 8)) 11 | 12 | (defun make-octet-vector (size) 13 | (make-array size :element-type 'octet 14 | :initial-element 0)) 15 | 16 | (defun octet-vector (&rest octets) 17 | (make-array (length octets) :element-type 'octet 18 | :initial-contents octets)) 19 | 20 | ;;; ASCII characters as integers 21 | 22 | (defun acode (char) 23 | (cond ((eql char :cr) 24 | 13) 25 | ((eql char :lf) 26 | 10) 27 | ((eql char :tab) 28 | 9) 29 | (t 30 | (let ((code (char-code char))) 31 | (if (<= 0 code 127) 32 | code 33 | (error "Character ~S is not in the ASCII character set" 34 | char)))))) 35 | 36 | (defvar *whitespace* 37 | (list (acode #\Space) (acode :tab) (acode :cr) (acode :lf))) 38 | 39 | (defun whitep (code) 40 | (member code *whitespace*)) 41 | 42 | (defun ascii-vector (string) 43 | (let ((vector (make-octet-vector (length string)))) 44 | (loop for char across string 45 | for code = (char-code char) 46 | for i from 0 47 | if (< 127 code) do 48 | (error "Invalid character for ASCII -- ~A" char) 49 | else 50 | do (setf (aref vector i) code)) 51 | vector)) 52 | 53 | (defun ascii-subseq (vector start end) 54 | "Return a subseq of octet-specialized VECTOR as a string." 55 | (let ((string (make-string (- end start)))) 56 | (loop for i from 0 57 | for j from start below end 58 | do (setf (char string i) (code-char (aref vector j)))) 59 | string)) 60 | 61 | (defun ascii-downcase (code) 62 | (if (<= 65 code 90) 63 | (+ code 32) 64 | code)) 65 | 66 | (defun ascii-equal (a b) 67 | (eql (ascii-downcase a) (ascii-downcase b))) 68 | 69 | (defmacro acase (value &body cases) 70 | (flet ((convert-case-keys (keys) 71 | (mapcar (lambda (key) 72 | (etypecase key 73 | (integer key) 74 | (character (char-code key)) 75 | (symbol 76 | (ecase key 77 | (:cr 13) 78 | (:lf 10) 79 | (:tab 9) 80 | ((t) t))))) 81 | (if (consp keys) keys (list keys))))) 82 | `(case ,value 83 | ,@(mapcar (lambda (case) 84 | (destructuring-bind (keys &rest body) 85 | case 86 | `(,(or (eql keys t) 87 | (convert-case-keys keys)) 88 | ,@body))) 89 | cases)))) 90 | 91 | ;;; Pattern matching (for finding headers) 92 | 93 | (defclass matcher () 94 | ((pattern 95 | :initarg :pattern 96 | :reader pattern) 97 | (pos 98 | :initform 0 99 | :accessor match-pos) 100 | (matchedp 101 | :initform nil 102 | :accessor matchedp))) 103 | 104 | (defun reset-match (matcher) 105 | (setf (match-pos matcher) 0 106 | (matchedp matcher) nil)) 107 | 108 | (define-condition match-failure (error) ()) 109 | 110 | (defun match (matcher input &key (start 0) end error) 111 | (let ((i start) 112 | (end (or end (length input))) 113 | (match-end (length (pattern matcher)))) 114 | (with-slots (pattern pos) 115 | matcher 116 | (loop 117 | (cond ((= pos match-end) 118 | (let ((match-start (- i pos))) 119 | (setf pos 0) 120 | (setf (matchedp matcher) t) 121 | (return (values match-start (+ match-start match-end))))) 122 | ((= i end) 123 | (return nil)) 124 | ((= (aref pattern pos) 125 | (aref input i)) 126 | (incf i) 127 | (incf pos)) 128 | (error 129 | (error 'match-failure)) 130 | ((zerop pos) 131 | (incf i)) 132 | (t 133 | (setf pos 0))))))) 134 | 135 | (defun ascii-matcher (string) 136 | (make-instance 'matcher 137 | :pattern (ascii-vector string))) 138 | 139 | (defun octet-matcher (&rest octets) 140 | (make-instance 'matcher 141 | :pattern (apply 'octet-vector octets))) 142 | 143 | (defun acode-matcher (&rest codes) 144 | (make-instance 'matcher 145 | :pattern (make-array (length codes) 146 | :element-type 'octet 147 | :initial-contents 148 | (mapcar 'acode codes)))) 149 | 150 | 151 | ;;; "Connection Buffers" are a kind of callback-driven, 152 | ;;; pattern-matching chunky stream. Callbacks can be called for a 153 | ;;; certain number of octets or until one or more patterns are seen in 154 | ;;; the input. cbufs automatically refill themselves from a 155 | ;;; connection as needed. 156 | 157 | (defvar *cbuf-buffer-size* 8192) 158 | 159 | (define-condition end-of-data (error) ()) 160 | 161 | (defclass cbuf () 162 | ((data 163 | :initarg :data 164 | :accessor data) 165 | (connection 166 | :initarg :connection 167 | :accessor connection) 168 | (start 169 | :initarg :start 170 | :accessor start) 171 | (end 172 | :initarg :end 173 | :accessor end) 174 | (eofp 175 | :initarg :eofp 176 | :accessor eofp)) 177 | (:default-initargs 178 | :data (make-octet-vector *cbuf-buffer-size*) 179 | :connection nil 180 | :start 0 181 | :end 0 182 | :eofp nil) 183 | (:documentation "A CBUF is a connection buffer that keeps track of 184 | incoming data from a connection. Several functions make it easy to 185 | treat a CBUF as a kind of chunky, callback-driven stream.")) 186 | 187 | (define-condition cbuf-progress () 188 | ((size 189 | :initarg :size 190 | :accessor cbuf-progress-size 191 | :initform 0))) 192 | 193 | (defun call-processor (fun cbuf start end) 194 | (signal 'cbuf-progress :size (- end start)) 195 | (funcall fun (data cbuf) start end)) 196 | 197 | (defun make-cbuf (connection) 198 | (make-instance 'cbuf :connection connection)) 199 | 200 | (defun make-stream-writer (stream) 201 | "Create a callback for writing data to STREAM." 202 | (lambda (data start end) 203 | (write-sequence data stream :start start :end end))) 204 | 205 | (defgeneric size (cbuf) 206 | (:method ((cbuf cbuf)) 207 | (- (end cbuf) (start cbuf)))) 208 | 209 | (defgeneric emptyp (cbuf) 210 | (:method ((cbuf cbuf)) 211 | (zerop (size cbuf)))) 212 | 213 | (defgeneric refill (cbuf) 214 | (:method ((cbuf cbuf)) 215 | (when (eofp cbuf) 216 | (error 'end-of-data)) 217 | (setf (start cbuf) 0) 218 | (setf (end cbuf) 219 | (read-octets (data cbuf) 220 | (connection cbuf))) 221 | (cond ((emptyp cbuf) 222 | (setf (eofp cbuf) t) 223 | (error 'end-of-data)) 224 | (t (size cbuf))))) 225 | 226 | (defun process-all (fun cbuf) 227 | (unless (emptyp cbuf) 228 | (call-processor fun cbuf (start cbuf) (end cbuf)))) 229 | 230 | (defun multi-cmatch (matchers cbuf) 231 | (let ((start nil) 232 | (end nil)) 233 | (dolist (matcher matchers (values start end)) 234 | (multiple-value-bind (s e) 235 | (match matcher (data cbuf) 236 | :start (start cbuf) 237 | :end (end cbuf)) 238 | (when (and s (or (null start) (< s start))) 239 | (setf start s 240 | end e)))))) 241 | 242 | (defun cmatch (matcher cbuf) 243 | (if (consp matcher) 244 | (multi-cmatch matcher cbuf) 245 | (match matcher (data cbuf) :start (start cbuf) :end (end cbuf)))) 246 | 247 | (defun call-until-end (fun cbuf) 248 | (handler-case 249 | (loop 250 | (process-all fun cbuf) 251 | (refill cbuf)) 252 | (end-of-data () 253 | (return-from call-until-end)))) 254 | 255 | (defun show-cbuf (context cbuf) 256 | (format t "cbuf: ~A ~D - ~D~%" context (start cbuf) (end cbuf))) 257 | 258 | (defun call-for-n-octets (n fun cbuf) 259 | (let ((remaining n)) 260 | (loop 261 | (when (<= remaining (size cbuf)) 262 | (let ((end (+ (start cbuf) remaining))) 263 | (call-processor fun cbuf (start cbuf) end) 264 | (setf (start cbuf) end) 265 | (return))) 266 | (process-all fun cbuf) 267 | (decf remaining (size cbuf)) 268 | (refill cbuf)))) 269 | 270 | (defun call-until-matching (matcher fun cbuf) 271 | (loop 272 | (multiple-value-bind (start end) 273 | (cmatch matcher cbuf) 274 | (when start 275 | (call-processor fun cbuf (start cbuf) end) 276 | (setf (start cbuf) end) 277 | (return))) 278 | (process-all fun cbuf) 279 | (refill cbuf))) 280 | 281 | (defun ignore-data (data start end) 282 | (declare (ignore data start end))) 283 | 284 | (defun skip-until-matching (matcher cbuf) 285 | (call-until-matching matcher 'ignore-data cbuf)) 286 | 287 | 288 | ;;; Creating HTTP requests as octet buffers 289 | 290 | (defclass octet-sink () 291 | ((storage 292 | :initarg :storage 293 | :accessor storage)) 294 | (:default-initargs 295 | :storage (make-array 1024 :element-type 'octet 296 | :fill-pointer 0 297 | :adjustable t)) 298 | (:documentation "A simple stream-like target for collecting 299 | octets.")) 300 | 301 | (defun add-octet (octet sink) 302 | (vector-push-extend octet (storage sink))) 303 | 304 | (defun add-octets (octets sink &key (start 0) end) 305 | (setf end (or end (length octets))) 306 | (loop for i from start below end 307 | do (add-octet (aref octets i) sink))) 308 | 309 | (defun add-string (string sink) 310 | (loop for char across string 311 | for code = (char-code char) 312 | do (add-octet code sink))) 313 | 314 | (defun add-strings (sink &rest strings) 315 | (mapc (lambda (string) (add-string string sink)) strings)) 316 | 317 | (defun add-newline (sink) 318 | (add-octet 13 sink) 319 | (add-octet 10 sink)) 320 | 321 | (defun sink-buffer (sink) 322 | (subseq (storage sink) 0)) 323 | 324 | (defvar *proxy-url* (config-value "proxy-url")) 325 | 326 | (defun full-proxy-path (host port path) 327 | (format nil "~:[http~;https~]://~A~:[:~D~;~*~]~A" 328 | (eql port 443) 329 | host 330 | (or (null port) 331 | (= port 80) 332 | (= port 443)) 333 | port 334 | path)) 335 | 336 | (defun user-agent-string () 337 | "Return a string suitable for using as the User-Agent value in HTTP 338 | requests. Includes Quicklisp version and CL implementation and version 339 | information." 340 | (labels ((requires-encoding (char) 341 | (not (or (alphanumericp char) 342 | (member char '(#\. #\- #\_))))) 343 | (encode (string) 344 | (substitute-if #\_ #'requires-encoding string)) 345 | (version-string (string) 346 | (if (string-equal string nil) 347 | "unknown" 348 | (let* ((length (length string)) 349 | (start (or (position-if #'digit-char-p string) 350 | 0)) 351 | (space (or (position #\Space string :start start) 352 | length)) 353 | (limit (min space length (+ start 24)))) 354 | (encode (subseq string start limit)))))) 355 | ;; FIXME: Be more configurable, and take/set the version from 356 | ;; somewhere else. 357 | (format nil "quicklisp-client/~A ~A/~A" 358 | ql-info:*version* 359 | (encode (lisp-implementation-type)) 360 | (version-string (lisp-implementation-version))))) 361 | 362 | (defun make-request-buffer (host port path &key (method "GET")) 363 | "Return an octet vector suitable for sending as an HTTP 1.1 request." 364 | (setf method (string method)) 365 | (when *proxy-url* 366 | (setf path (full-proxy-path host port path))) 367 | (let ((sink (make-instance 'octet-sink))) 368 | (flet ((add-line (&rest strings) 369 | (apply #'add-strings sink strings) 370 | (add-newline sink))) 371 | (add-line method " " path " HTTP/1.1") 372 | (add-line "Host: " host (if (integerp port) 373 | (format nil ":~D" port) 374 | "")) 375 | (add-line "Connection: close") 376 | (add-line "User-Agent: " (user-agent-string)) 377 | (add-newline sink) 378 | (sink-buffer sink)))) 379 | 380 | (defun sink-until-matching (matcher cbuf) 381 | (let ((sink (make-instance 'octet-sink))) 382 | (call-until-matching 383 | matcher 384 | (lambda (buffer start end) 385 | (add-octets buffer sink :start start :end end)) 386 | cbuf) 387 | (sink-buffer sink))) 388 | 389 | 390 | ;;; HTTP headers 391 | 392 | (defclass header () 393 | ((data 394 | :initarg :data 395 | :accessor data) 396 | (status 397 | :initarg :status 398 | :accessor status) 399 | (name-starts 400 | :initarg :name-starts 401 | :accessor name-starts) 402 | (name-ends 403 | :initarg :name-ends 404 | :accessor name-ends) 405 | (value-starts 406 | :initarg :value-starts 407 | :accessor value-starts) 408 | (value-ends 409 | :initarg :value-ends 410 | :accessor value-ends))) 411 | 412 | (defmethod print-object ((header header) stream) 413 | (print-unreadable-object (header stream :type t) 414 | (prin1 (status header) stream))) 415 | 416 | (defun matches-at (pattern target pos) 417 | (= (mismatch pattern target :start2 pos) (length pattern))) 418 | 419 | (defun header-value-indexes (field-name header) 420 | (loop with data = (data header) 421 | with pattern = (ascii-vector (string-downcase field-name)) 422 | for start across (name-starts header) 423 | for i from 0 424 | when (matches-at pattern data start) 425 | return (values (aref (value-starts header) i) 426 | (aref (value-ends header) i)))) 427 | 428 | (defun ascii-header-value (field-name header) 429 | (multiple-value-bind (start end) 430 | (header-value-indexes field-name header) 431 | (when start 432 | (ascii-subseq (data header) start end)))) 433 | 434 | (defun all-field-names (header) 435 | (map 'list 436 | (lambda (start end) 437 | (ascii-subseq (data header) start end)) 438 | (name-starts header) 439 | (name-ends header))) 440 | 441 | (defun headers-alist (header) 442 | (mapcar (lambda (name) 443 | (cons name (ascii-header-value name header))) 444 | (all-field-names header))) 445 | 446 | (defmethod describe-object :after ((header header) stream) 447 | (format stream "~&Decoded headers:~% ~S~%" (headers-alist header))) 448 | 449 | (defun content-length (header) 450 | (let ((field-value (ascii-header-value "content-length" header))) 451 | (when field-value 452 | (let ((value (ignore-errors (parse-integer field-value)))) 453 | (or value 454 | (error "Content-Length header field value is not a number -- ~A" 455 | field-value)))))) 456 | 457 | (defun chunkedp (header) 458 | (string= (ascii-header-value "transfer-encoding" header) "chunked")) 459 | 460 | (defun location (header) 461 | (ascii-header-value "location" header)) 462 | 463 | (defun status-code (vector) 464 | (let* ((space (position (acode #\Space) vector)) 465 | (c1 (- (aref vector (incf space)) 48)) 466 | (c2 (- (aref vector (incf space)) 48)) 467 | (c3 (- (aref vector (incf space)) 48))) 468 | (+ (* c1 100) 469 | (* c2 10) 470 | (* c3 1)))) 471 | 472 | (defun force-downcase-field-names (header) 473 | (loop with data = (data header) 474 | for start across (name-starts header) 475 | for end across (name-ends header) 476 | do (loop for i from start below end 477 | for code = (aref data i) 478 | do (setf (aref data i) (ascii-downcase code))))) 479 | 480 | (defun skip-white-forward (pos vector) 481 | (position-if-not 'whitep vector :start pos)) 482 | 483 | (defun skip-white-backward (pos vector) 484 | (let ((nonwhite (position-if-not 'whitep vector :end pos :from-end t))) 485 | (if nonwhite 486 | (1+ nonwhite) 487 | pos))) 488 | 489 | (defun contract-field-value-indexes (header) 490 | "Header field values exclude leading and trailing whitespace; adjust 491 | the indexes in the header accordingly." 492 | (loop with starts = (value-starts header) 493 | with ends = (value-ends header) 494 | with data = (data header) 495 | for i from 0 496 | for start across starts 497 | for end across ends 498 | do 499 | (setf (aref starts i) (skip-white-forward start data)) 500 | (setf (aref ends i) (skip-white-backward end data)))) 501 | 502 | (defun next-line-pos (vector) 503 | (let ((pos 0)) 504 | (labels ((finish (&optional (i pos)) 505 | (return-from next-line-pos i)) 506 | (after-cr (code) 507 | (acase code 508 | (:lf (finish pos)) 509 | (t (finish (1- pos))))) 510 | (pending (code) 511 | (acase code 512 | (:cr #'after-cr) 513 | (:lf (finish pos)) 514 | (t #'pending)))) 515 | (let ((state #'pending)) 516 | (loop 517 | (setf state (funcall state (aref vector pos))) 518 | (incf pos)))))) 519 | 520 | (defun make-hvector () 521 | (make-array 16 :fill-pointer 0 :adjustable t)) 522 | 523 | (defun process-header (vector) 524 | "Create a HEADER instance from the octet data in VECTOR." 525 | (let* ((name-starts (make-hvector)) 526 | (name-ends (make-hvector)) 527 | (value-starts (make-hvector)) 528 | (value-ends (make-hvector)) 529 | (header (make-instance 'header 530 | :data vector 531 | :status 999 532 | :name-starts name-starts 533 | :name-ends name-ends 534 | :value-starts value-starts 535 | :value-ends value-ends)) 536 | (mark nil) 537 | (pos (next-line-pos vector))) 538 | (unless pos 539 | (error "Unable to process HTTP header")) 540 | (setf (status header) (status-code vector)) 541 | (labels ((save (value vector) 542 | (vector-push-extend value vector)) 543 | (mark () 544 | (setf mark pos)) 545 | (clear-mark () 546 | (setf mark nil)) 547 | (finish () 548 | (if mark 549 | (save mark value-ends) 550 | (save pos value-ends)) 551 | (force-downcase-field-names header) 552 | (contract-field-value-indexes header) 553 | (return-from process-header header)) 554 | (in-new-line (code) 555 | (acase code 556 | ((:tab #\Space) (setf mark nil) #'in-value) 557 | (t 558 | (when mark 559 | (save mark value-ends)) 560 | (clear-mark) 561 | (save pos name-starts) 562 | (in-name code)))) 563 | (after-cr (code) 564 | (acase code 565 | (:lf #'in-new-line) 566 | (t (in-new-line code)))) 567 | (in-name (code) 568 | (acase code 569 | (#\: 570 | (save pos name-ends) 571 | (save (1+ pos) value-starts) 572 | #'in-value) 573 | ((:cr :lf) 574 | (finish)) 575 | ((:tab #\Space) 576 | (error "Unexpected whitespace in header field name")) 577 | (t 578 | (unless (<= 0 code 127) 579 | (error "Unexpected non-ASCII header field name")) 580 | #'in-name))) 581 | (in-value (code) 582 | (acase code 583 | (:lf (mark) #'in-new-line) 584 | (:cr (mark) #'after-cr) 585 | (t #'in-value)))) 586 | (let ((state #'in-new-line)) 587 | (loop 588 | (incf pos) 589 | (when (<= (length vector) pos) 590 | (error "No header found in response")) 591 | (setf state (funcall state (aref vector pos)))))))) 592 | 593 | 594 | ;;; HTTP URL parsing 595 | 596 | (defclass url () 597 | ((scheme 598 | :initarg :scheme 599 | :accessor scheme 600 | :initform nil) 601 | (hostname 602 | :initarg :hostname 603 | :accessor hostname 604 | :initform nil) 605 | (port 606 | :initarg :port 607 | :accessor port 608 | :initform nil) 609 | (path 610 | :initarg :path 611 | :accessor path 612 | :initform "/"))) 613 | 614 | (defun parse-urlstring (urlstring) 615 | (setf urlstring (string-trim " " urlstring)) 616 | (let* ((pos (position #\: urlstring)) 617 | (scheme (or (and pos (subseq urlstring 0 pos)) "http")) 618 | (pos (mismatch urlstring "://" :test 'char-equal :start1 pos)) 619 | (mark pos) 620 | (url (make-instance 'url))) 621 | (setf (scheme url) scheme) 622 | (labels ((save () 623 | (subseq urlstring mark pos)) 624 | (mark () 625 | (setf mark pos)) 626 | (finish () 627 | (return-from parse-urlstring url)) 628 | (hostname-char-p (char) 629 | (position char "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_." 630 | :test 'char-equal)) 631 | (at-start (char) 632 | (case char 633 | (#\/ 634 | (setf (port url) nil) 635 | (mark) 636 | #'in-path) 637 | (t 638 | #'in-host))) 639 | (in-host (char) 640 | (case char 641 | ((#\/ :end) 642 | (setf (hostname url) (save)) 643 | (mark) 644 | #'in-path) 645 | (#\: 646 | (setf (hostname url) (save)) 647 | (mark) 648 | #'in-port) 649 | (t 650 | (unless (hostname-char-p char) 651 | (error "~S is not a valid URL" urlstring)) 652 | #'in-host))) 653 | (in-port (char) 654 | (case char 655 | ((#\/ :end) 656 | (setf (port url) 657 | (parse-integer urlstring 658 | :start (1+ mark) 659 | :end pos)) 660 | (mark) 661 | #'in-path) 662 | (t 663 | (unless (digit-char-p char) 664 | (error "Bad port in URL ~S" urlstring)) 665 | #'in-port))) 666 | (in-path (char) 667 | (case char 668 | ((#\# :end) 669 | (setf (path url) (save)) 670 | (finish))) 671 | #'in-path)) 672 | (let ((state #'at-start)) 673 | (loop 674 | (when (<= (length urlstring) pos) 675 | (funcall state :end) 676 | (finish)) 677 | (setf state (funcall state (aref urlstring pos))) 678 | (incf pos)))))) 679 | 680 | (defun url (thing) 681 | (if (stringp thing) 682 | (parse-urlstring thing) 683 | thing)) 684 | 685 | (defgeneric request-buffer (method url) 686 | (:method (method url) 687 | (setf url (url url)) 688 | (make-request-buffer (hostname url) (or (port url) 80) (path url) 689 | :method method))) 690 | 691 | (defun urlstring (url) 692 | (format nil "~@[~A://~]~@[~A~]~@[:~D~]~A" 693 | (and (hostname url) (scheme url)) 694 | (hostname url) 695 | (port url) 696 | (path url))) 697 | 698 | (defmethod print-object ((url url) stream) 699 | (print-unreadable-object (url stream :type t) 700 | (prin1 (urlstring url) stream))) 701 | 702 | (defun merge-urls (url1 url2) 703 | (setf url1 (url url1)) 704 | (setf url2 (url url2)) 705 | (make-instance 'url 706 | :scheme (or (scheme url1) 707 | (scheme url2)) 708 | :hostname (or (hostname url1) 709 | (hostname url2)) 710 | :port (or (port url1) 711 | (port url2)) 712 | :path (or (path url1) 713 | (path url2)))) 714 | 715 | 716 | ;;; Requesting an URL and saving it to a file 717 | 718 | (defparameter *maximum-redirects* 10) 719 | (defvar *default-url-defaults* (url "http://src.quicklisp.org/")) 720 | 721 | (defun read-http-header (cbuf) 722 | (let ((header-data (sink-until-matching (list (acode-matcher :lf :lf) 723 | (acode-matcher :cr :cr) 724 | (acode-matcher :cr :lf :cr :lf)) 725 | cbuf))) 726 | (process-header header-data))) 727 | 728 | (defun read-chunk-header (cbuf) 729 | (let* ((header-data (sink-until-matching (acode-matcher :cr :lf) cbuf)) 730 | (end (or (position (acode :cr) header-data) 731 | (position (acode #\;) header-data)))) 732 | (values (parse-integer (ascii-subseq header-data 0 end) :radix 16)))) 733 | 734 | (defun save-chunk-response (stream cbuf) 735 | "For a chunked response, read all chunks and write them to STREAM." 736 | (let ((fun (make-stream-writer stream)) 737 | (matcher (acode-matcher :cr :lf))) 738 | (loop 739 | (let ((chunk-size (read-chunk-header cbuf))) 740 | (when (zerop chunk-size) 741 | (return)) 742 | (call-for-n-octets chunk-size fun cbuf) 743 | (skip-until-matching matcher cbuf))))) 744 | 745 | (defun save-response (file header cbuf &key (if-exists :rename-and-delete)) 746 | (with-open-file (stream file 747 | :direction :output 748 | :if-exists if-exists 749 | :element-type 'octet) 750 | (let ((content-length (content-length header))) 751 | (cond ((chunkedp header) 752 | (save-chunk-response stream cbuf)) 753 | (content-length 754 | (call-for-n-octets content-length 755 | (make-stream-writer stream) 756 | cbuf)) 757 | (t 758 | (call-until-end (make-stream-writer stream) cbuf)))))) 759 | 760 | (defun call-with-progress-bar (size fun) 761 | (let ((progress-bar (make-progress-bar size))) 762 | (start-display progress-bar) 763 | (flet ((update (condition) 764 | (update-progress progress-bar 765 | (cbuf-progress-size condition)))) 766 | (handler-bind ((cbuf-progress #'update)) 767 | (funcall fun))) 768 | (finish-display progress-bar))) 769 | 770 | (define-condition fetch-error (error) ()) 771 | 772 | (define-condition unexpected-http-status (fetch-error) 773 | ((status-code 774 | :initarg :status-code 775 | :reader unexpected-http-status-code) 776 | (url 777 | :initarg :url 778 | :reader unexpected-http-status-url)) 779 | (:report 780 | (lambda (condition stream) 781 | (format stream "Unexpected HTTP status for ~A: ~A" 782 | (unexpected-http-status-url condition) 783 | (unexpected-http-status-code condition))))) 784 | 785 | (define-condition too-many-redirects (fetch-error) 786 | ((url 787 | :initarg :url 788 | :reader too-many-redirects-url) 789 | (redirect-count 790 | :initarg :redirect-count 791 | :reader too-many-redirects-count)) 792 | (:report 793 | (lambda (condition stream) 794 | (format stream "Too many redirects (~:D) for ~A" 795 | (too-many-redirects-count condition) 796 | (too-many-redirects-url condition))))) 797 | 798 | (defvar *fetch-scheme-functions* 799 | '(("http" . http-fetch)) 800 | "assoc list to decide which scheme-function are called by FETCH function.") 801 | 802 | (defun fetch (url file &rest rest) 803 | "Request URL and write the body of the response to FILE." 804 | (let* ((url (merge-urls url *default-url-defaults*)) 805 | (call (cdr (assoc (scheme url) *fetch-scheme-functions* :test 'equal)))) 806 | (if call 807 | (apply call (urlstring url) file rest) 808 | (error "Unknown scheme ~S" url)))) 809 | 810 | (defun http-fetch (url file &key (follow-redirects t) quietly 811 | (if-exists :rename-and-delete) 812 | (maximum-redirects *maximum-redirects*)) 813 | "default scheme-function for http protocol." 814 | (setf url (merge-urls url *default-url-defaults*)) 815 | (setf file (merge-pathnames file)) 816 | (let ((redirect-count 0) 817 | (original-url url) 818 | (connect-url (or (url *proxy-url*) url)) 819 | (stream (if quietly 820 | (make-broadcast-stream) 821 | *trace-output*))) 822 | (loop 823 | (when (<= maximum-redirects redirect-count) 824 | (error 'too-many-redirects 825 | :url original-url 826 | :redirect-count redirect-count)) 827 | (with-connection (connection (hostname connect-url) (or (port connect-url) 80)) 828 | (let ((cbuf (make-instance 'cbuf :connection connection)) 829 | (request (request-buffer "GET" url))) 830 | (write-octets request connection) 831 | (let ((header (read-http-header cbuf))) 832 | (loop while (= (status header) 100) 833 | do (setf header (read-http-header cbuf))) 834 | (cond ((= (status header) 200) 835 | (let ((size (content-length header))) 836 | (format stream "~&; Fetching ~A~%" url) 837 | (if (and (numberp size) 838 | (plusp size)) 839 | (format stream "; ~$KB~%" (/ size 1024)) 840 | (format stream "; Unknown size~%")) 841 | (if quietly 842 | (save-response file header cbuf 843 | :if-exists if-exists) 844 | (call-with-progress-bar 845 | (content-length header) 846 | (lambda () 847 | (save-response file header cbuf 848 | :if-exists if-exists)))))) 849 | ((not (<= 300 (status header) 399)) 850 | (error 'unexpected-http-status 851 | :url url 852 | :status-code (status header)))) 853 | (if (and follow-redirects (<= 300 (status header) 399)) 854 | (let ((new-urlstring (ascii-header-value "location" header))) 855 | (unless new-urlstring 856 | (error "Redirect code ~D received, but no Location: header" 857 | (status header))) 858 | (incf redirect-count) 859 | (setf url (merge-urls new-urlstring 860 | url)) 861 | (format stream "~&; Redirecting to ~A~%" url)) 862 | (return (values header (and file (probe-file file))))))))))) 863 | -------------------------------------------------------------------------------- /quicklisp/impl-util.lisp: -------------------------------------------------------------------------------- 1 | ;;;; impl-util.lisp 2 | 3 | (in-package #:ql-impl-util) 4 | 5 | (definterface call-with-quiet-compilation (fun) 6 | (:documentation 7 | "Call FUN with warnings, style-warnings, and other verbose messages 8 | suppressed.") 9 | (:implementation t 10 | (let ((*load-verbose* nil) 11 | (*compile-verbose* nil) 12 | (*load-print* nil) 13 | (*compile-print* nil)) 14 | (handler-bind ((warning #'muffle-warning)) 15 | (funcall fun))))) 16 | 17 | (defimplementation (call-with-quiet-compilation :for sbcl :qualifier :around) 18 | (fun) 19 | (declare (ignore fun)) 20 | (handler-bind ((ql-sbcl:compiler-note #'muffle-warning)) 21 | (call-next-method))) 22 | 23 | (defimplementation (call-with-quiet-compilation :for cmucl :qualifier :around) 24 | (fun) 25 | (declare (ignore fun)) 26 | (let ((ql-cmucl:*gc-verbose* nil)) 27 | (call-next-method))) 28 | 29 | (definterface rename-directory (from to) 30 | (:implementation t 31 | (rename-file from to) 32 | (truename to)) 33 | (:implementation cmucl 34 | (rename-file from (string-right-trim "/" (namestring to))) 35 | (truename to)) 36 | (:implementation clisp 37 | (ql-clisp:rename-directory from to) 38 | (truename to))) 39 | 40 | (definterface probe-directory (pathname) 41 | (:documentation "Return the truename of PATHNAME, if it exists and 42 | is a directory, or NIL otherwise.") 43 | (:implementation t 44 | (let ((directory (probe-file pathname))) 45 | (when directory 46 | ;; probe-file is specified to return the truename of the path, 47 | ;; but Allegro does not return the truename; truenamize it. 48 | (truename directory)))) 49 | (:implementation clisp 50 | (let ((directory (ql-clisp:probe-pathname pathname))) 51 | (when (and directory (ql-clisp:probe-directory directory)) 52 | directory)))) 53 | 54 | (definterface init-file-name () 55 | (:documentation "Return the init file name for the current implementation.") 56 | (:implementation allegro 57 | ".clinit.cl") 58 | (:implementation abcl 59 | ".abclrc") 60 | (:implementation ccl 61 | #+windows 62 | "ccl-init.lisp" 63 | #-windows 64 | ".ccl-init.lisp") 65 | (:implementation clasp 66 | ".clasprc") 67 | (:implementation clisp 68 | ".clisprc.lisp") 69 | (:implementation ecl 70 | ".eclrc") 71 | (:implementation mezzano 72 | "init.lisp") 73 | (:implementation mkcl 74 | ".mkclrc") 75 | (:implementation lispworks 76 | ".lispworks") 77 | (:implementation sbcl 78 | ".sbclrc") 79 | (:implementation cmucl 80 | ".cmucl-init.lisp") 81 | (:implementation scl 82 | ".scl-init.lisp") 83 | (:implementation genera 84 | "lispm-init.lisp") 85 | ) 86 | 87 | (defun init-file-name-for (&optional implementation-designator) 88 | (let* ((class-name (find-symbol (string-upcase implementation-designator) 89 | 'ql-impl)) 90 | (class (find-class class-name nil))) 91 | (when class 92 | (let ((*implementation* (make-instance class))) 93 | (init-file-name))))) 94 | 95 | (defun quicklisp-init-file-form () 96 | "Return a form suitable for describing the location of the quicklisp 97 | init file. If the file is available relative to the home directory, 98 | returns a form that merges with the home directory instead of 99 | specifying an absolute file." 100 | (let* ((init-file (ql-setup:qmerge "setup.lisp")) 101 | (enough (enough-namestring init-file (user-homedir-pathname)))) 102 | (cond ((equal (pathname enough) (pathname init-file)) 103 | ;; The init-file is somewhere outside of the home directory 104 | (pathname enough)) 105 | (t 106 | `(merge-pathnames ,enough (user-homedir-pathname)))))) 107 | 108 | (defun write-init-forms (stream &key (indentation 0)) 109 | (format stream "~%~v@T;;; The following lines added by ql:add-to-init-file:~%" 110 | indentation) 111 | (format stream "~v@T#-quicklisp~%" indentation) 112 | (let ((*print-case* :downcase)) 113 | (format stream "~v@T(let ((quicklisp-init ~S))~%" 114 | indentation 115 | (quicklisp-init-file-form))) 116 | (format stream "~v@T (load quicklisp-init :if-does-not-exist nil))~%" 117 | indentation)) 118 | 119 | (defun suitable-lisp-init-file (implementation) 120 | "Return the name of IMPLEMENTATION's init file. If IMPLEMENTAION is 121 | a string or pathname, return its merged pathname instead." 122 | (typecase implementation 123 | ((or string pathname) 124 | (merge-pathnames implementation)) 125 | ((or null (eql t)) 126 | (init-file-name)) 127 | (t 128 | (init-file-name-for implementation)))) 129 | 130 | (defun add-to-init-file (&optional implementation-or-file) 131 | "Add forms to the Lisp implementation's init file that will load 132 | quicklisp at CL startup." 133 | (let ((init-file (suitable-lisp-init-file implementation-or-file))) 134 | (unless init-file 135 | (error "Don't know how to add to init file for your implementation.")) 136 | (setf init-file (merge-pathnames init-file (user-homedir-pathname))) 137 | (format *query-io* "~&I will append the following lines to ~S:~%" 138 | init-file) 139 | (write-init-forms *query-io* :indentation 2) 140 | (when (ql-util:press-enter-to-continue) 141 | (with-open-file (stream init-file 142 | :direction :output 143 | :if-does-not-exist :create 144 | :if-exists :append) 145 | (write-init-forms stream))) 146 | init-file)) 147 | 148 | 149 | 150 | ;;; 151 | ;;; Native namestrings. 152 | ;;; 153 | 154 | (definterface native-namestring (pathname) 155 | (:documentation "In Clozure CL, #\\.s in pathname-names are escaped 156 | in namestrings with #\\> on Windows and #\\\\ elsewhere. This can 157 | cause a problem when using CL:NAMESTRING to store pathname data that 158 | might be used by other implementations. NATIVE-NAMESTRING is 159 | intended to provide a namestring that can be parsed as a same-enough 160 | object on multiple implementations.") 161 | (:implementation t 162 | (namestring pathname)) 163 | (:implementation ccl 164 | (ql-ccl:native-translated-namestring pathname)) 165 | (:implementation sbcl 166 | (ql-sbcl:native-namestring pathname))) 167 | 168 | 169 | ;;; 170 | ;;; Directory write date 171 | ;;; 172 | 173 | (definterface directory-write-date (pathname) 174 | (:documentation "Return the write-date of the directory designated 175 | by PATHNAME as a universal time, like file-write-date.") 176 | (:implementation t 177 | (file-write-date pathname)) 178 | (:implementation clisp 179 | (nth-value 2 (ql-clisp:probe-pathname pathname))) 180 | (:implementation genera 181 | (file-write-date (ql-genera:send pathname :directory-pathname-as-file)))) 182 | 183 | 184 | ;;; 185 | ;;; Deleting a directory tree 186 | ;;; 187 | 188 | (defvar *wild-entry* 189 | (make-pathname :name :wild :type :wild :version :wild)) 190 | 191 | (defvar *wild-relative* 192 | (make-pathname :directory '(:relative :wild))) 193 | 194 | (definterface directoryp (entry) 195 | (:documentation "Return true if ENTRY refers to a directory.") 196 | (:implementation t 197 | (not (or (pathname-name entry) 198 | (pathname-type entry)))) 199 | (:implementation allegro 200 | (ql-allegro:file-directory-p entry :follow-symbolic-links nil)) 201 | (:implementation lispworks 202 | (ql-lispworks:file-directory-p entry)) 203 | (:implementation genera 204 | (let ((path (if (call-next-method) 205 | (ql-genera:send entry :directory-pathname-as-file) 206 | entry))) 207 | (getf (cdr (ql-genera:file-properties path)) ':directory)))) 208 | 209 | (definterface directory-entries (directory) 210 | (:documentation "Return all directory entries of DIRECTORY as a 211 | list, or NIL if there are no directory entries. Excludes the \".\" 212 | and \"..\" entries.") 213 | (:implementation allegro 214 | (directory directory 215 | #+allegro :directories-are-files 216 | #+allegro nil 217 | #+allegro :follow-symbolic-links 218 | #+allegro nil)) 219 | (:implementation abcl 220 | (directory (merge-pathnames *wild-entry* directory) 221 | #+abcl :resolve-symlinks #+abcl nil)) 222 | (:implementation ccl 223 | (directory (merge-pathnames *wild-entry* directory) 224 | #+ccl :directories #+ccl t 225 | #+ccl :follow-links #+ccl nil)) 226 | (:implementation clasp 227 | (nconc 228 | (directory (merge-pathnames *wild-entry* directory) 229 | #+clasp :resolve-symlinks #+clasp nil) 230 | (directory (merge-pathnames *wild-relative* directory) 231 | #+clasp :resolve-symlinks #+clasp nil))) 232 | (:implementation clisp 233 | ;; :full gives pathnames as well as truenames, BUT: it returns a 234 | ;; singleton pathname, not a list, on dead symlinks. 235 | (remove nil 236 | (mapcar (lambda (entry) (and (listp entry) (first entry))) 237 | (nconc (directory (merge-pathnames *wild-entry* directory) 238 | #+clisp :full #+clisp t 239 | #+clisp :if-does-not-exist #+clisp :keep) 240 | (directory (merge-pathnames *wild-relative* directory) 241 | #+clisp :full #+clisp t 242 | #+clisp :if-does-not-exist #+clisp :keep))))) 243 | (:implementation cmucl 244 | (directory (merge-pathnames *wild-entry* directory) 245 | #+cmucl :truenamep #+cmucl nil)) 246 | (:implementation scl 247 | (directory (merge-pathnames *wild-entry* directory) 248 | #+scl :truenamep #+scl nil)) 249 | (:implementation lispworks 250 | (directory (merge-pathnames *wild-entry* directory) 251 | #+lispworks :directories #+lispworks t 252 | #+lispworks :link-transparency #+lispworks nil)) 253 | (:implementation ecl 254 | (nconc 255 | (directory (merge-pathnames *wild-entry* directory) 256 | #+ecl :resolve-symlinks #+ecl nil) 257 | (directory (merge-pathnames *wild-relative* directory) 258 | #+ecl :resolve-symlinks #+ecl nil))) 259 | (:implementation genera 260 | (let ((entries (ql-genera:directory-list (merge-pathnames *wild-entry* directory)))) 261 | (loop for (pathname . properties) in (cdr entries) 262 | if (getf properties ':directory) 263 | collect (ql-genera:send pathname :pathname-as-directory) 264 | else 265 | collect pathname))) 266 | (:implementation mezzano 267 | (directory (merge-pathnames *wild-entry* directory))) 268 | (:implementation mkcl 269 | (setf directory (truename directory)) 270 | (nconc 271 | (directory (merge-pathnames *wild-entry* directory)) 272 | (directory (merge-pathnames *wild-relative* directory)))) 273 | (:implementation sbcl 274 | (directory (merge-pathnames *wild-entry* directory) 275 | #+sbcl :resolve-symlinks #+sbcl nil))) 276 | 277 | (defimplementation (directory-entries :qualifier :around) (directory) 278 | ;; Don't return any entries when called with a non-directory 279 | ;; argument 280 | (if (directoryp directory) 281 | (call-next-method) 282 | (warn "directory-entries - not a directory -- ~S" directory))) 283 | 284 | (definterface delete-directory (entry) 285 | (:documentation "Delete the directory ENTRY. Might signal an error 286 | if it is not an empty directory.") 287 | (:implementation t 288 | (delete-file entry)) 289 | (:implementation allegro 290 | (ql-allegro:delete-directory entry)) 291 | (:implementation ccl 292 | (ql-ccl:delete-directory entry)) 293 | (:implementation clasp 294 | (ql-clasp:rmdir entry)) 295 | (:implementation clisp 296 | (ql-clisp:delete-directory entry)) 297 | (:implementation cmucl 298 | (ql-cmucl:unix-rmdir (namestring entry))) 299 | (:implementation scl 300 | (ql-scl:unix-rmdir (ql-scl:unix-namestring entry))) 301 | (:implementation ecl 302 | (ql-ecl:rmdir entry)) 303 | (:implementation genera 304 | (ql-genera:delete-directory entry :confirm nil)) 305 | (:implementation mkcl 306 | (ql-mkcl:rmdir entry)) 307 | (:implementation lispworks 308 | (ql-lispworks:delete-directory entry)) 309 | (:implementation sbcl 310 | (ql-sbcl:rmdir entry))) 311 | 312 | (defimplementation (delete-directory :qualifier :around) (directory) 313 | ;; Don't delete non-directories with delete-directory 314 | (if (directoryp directory) 315 | (call-next-method) 316 | (error "delete-directory - not a directory -- ~A" directory))) 317 | 318 | (definterface delete-directory-tree (pathname) 319 | (:documentation "Delete the directory tree rooted at PATHNAME.") 320 | (:implementation t 321 | (let ((directories-to-process (list (truename pathname))) 322 | (directories-to-delete '())) 323 | (loop 324 | (unless directories-to-process 325 | (return)) 326 | (let* ((current (pop directories-to-process)) 327 | (entries (directory-entries current))) 328 | (push current directories-to-delete) 329 | (dolist (entry entries) 330 | (if (directoryp entry) 331 | (push entry directories-to-process) 332 | (delete-file entry))))) 333 | (map nil 'delete-directory directories-to-delete))) 334 | (:implementation allegro 335 | (ql-allegro:delete-directory-and-files pathname)) 336 | (:implementation ccl 337 | (ql-ccl:delete-directory pathname))) 338 | 339 | (defimplementation (delete-directory-tree :qualifier :around) (pathname) 340 | (cond ((directoryp pathname) 341 | (call-next-method)) 342 | (t 343 | (warn "delete-directory-tree - not a directory, ~ 344 | deleting anyway -- ~s" pathname) 345 | (delete-file pathname)))) 346 | 347 | (defun map-directory-tree (directory fun) 348 | "Call FUN for every file in directory and all its subdirectories, 349 | recursively. Uses the truename of directory as a starting point. Does 350 | not follow symlinks, but, on some implementations, DOES include 351 | potentially dead symlinks." 352 | (let ((directories-to-process (list (truename directory)))) 353 | (loop 354 | (unless directories-to-process 355 | (return)) 356 | (let* ((current (pop directories-to-process)) 357 | (entries (directory-entries current))) 358 | (dolist (entry entries) 359 | (if (directoryp entry) 360 | (push entry directories-to-process) 361 | (funcall fun entry))))))) 362 | 363 | -------------------------------------------------------------------------------- /quicklisp/impl.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ql-impl) 2 | 3 | (eval-when (:compile-toplevel :load-toplevel :execute) 4 | (defun error-unimplemented (&rest args) 5 | (declare (ignore args)) 6 | (error "Not implemented"))) 7 | 8 | (defvar *interfaces* (make-hash-table) 9 | "A table of defined interfaces and their documentation.") 10 | 11 | (defun show-interfaces () 12 | "Display information about what interfaces are defined." 13 | (maphash (lambda (interface info) 14 | (destructuring-bind (arguments docstring) 15 | info 16 | (let ((*package* (find-package :keyword))) 17 | (format t "(~S ~:[()~;~:*~A~]~@[~% ~S~])~%" 18 | interface arguments docstring)))) 19 | *interfaces*)) 20 | 21 | (defmacro neuter-package (name) 22 | `(eval-when (:compile-toplevel :load-toplevel :execute) 23 | (let ((definition (fdefinition 'error-unimplemented))) 24 | (do-external-symbols (symbol ,(string name)) 25 | (unless (fboundp symbol) 26 | (setf (fdefinition symbol) definition)))))) 27 | 28 | (eval-when (:compile-toplevel :load-toplevel :execute) 29 | (defun feature-expression-passes-p (expression) 30 | (cond ((keywordp expression) 31 | (member expression *features*)) 32 | ((consp expression) 33 | (case (first expression) 34 | (or 35 | (some 'feature-expression-passes-p (rest expression))) 36 | (and 37 | (every 'feature-expression-passes-p (rest expression))))) 38 | (t (error "Unrecognized feature expression -- ~S" expression))))) 39 | 40 | 41 | (defmacro define-implementation-package (feature package-name &rest options) 42 | (let* ((output-options '((:use) 43 | (:export #:lisp))) 44 | (prep (cdr (assoc :prep options))) 45 | (class-option (cdr (assoc :class options))) 46 | (class (first class-option)) 47 | (superclasses (rest class-option)) 48 | (import-options '()) 49 | (effectivep (feature-expression-passes-p feature))) 50 | (dolist (option options) 51 | (ecase (first option) 52 | ((:prep :class)) 53 | ((:import-from 54 | :import) 55 | (push option import-options)) 56 | ((:export 57 | :shadow 58 | :intern 59 | :documentation) 60 | (push option output-options)) 61 | ((:reexport-from) 62 | (push (cons :export (cddr option)) output-options) 63 | (push (cons :import-from (cdr option)) import-options)))) 64 | `(progn 65 | ,@(when effectivep 66 | `((eval-when (:compile-toplevel :load-toplevel :execute) 67 | ,@prep))) 68 | (defclass ,class ,superclasses ()) 69 | (defpackage ,package-name ,@output-options 70 | ,@(when effectivep 71 | import-options)) 72 | ,@(when effectivep 73 | `((setf *implementation* (make-instance ',class)))) 74 | ,@(unless effectivep 75 | `((neuter-package ,package-name)))))) 76 | 77 | (defmacro definterface (name lambda-list &body options) 78 | (let* ((doc-option (find :documentation options :key #'first)) 79 | (doc (second doc-option))) 80 | (setf (gethash name *interfaces*) (list lambda-list doc))) 81 | (let* ((forbidden (intersection lambda-list lambda-list-keywords)) 82 | (gf-options (remove :implementation options :key #'first)) 83 | (implementations (set-difference options gf-options)) 84 | (implementation-arg (copy-symbol '%implementation))) 85 | (when forbidden 86 | (error "~S not allowed in definterface lambda list" forbidden)) 87 | (flet ((method-option (class body) 88 | `(:method ((,implementation-arg ,class) ,@lambda-list) 89 | ,@body))) 90 | (let ((generic-name (intern (format nil "%~A" name)))) 91 | `(progn 92 | (defgeneric ,generic-name (lisp ,@lambda-list) 93 | ,@gf-options 94 | ,@(mapcan (lambda (implementation) 95 | (destructuring-bind (class &rest body) 96 | (rest implementation) 97 | (mapcar (lambda (class) 98 | (method-option class body)) 99 | (if (consp class) 100 | class 101 | (list class))))) 102 | implementations)) 103 | (defun ,name ,lambda-list 104 | (,generic-name *implementation* ,@lambda-list))))))) 105 | 106 | (defmacro defimplementation (name-and-options 107 | lambda-list &body body) 108 | (destructuring-bind (name &key (for t) qualifier) 109 | (if (consp name-and-options) 110 | name-and-options 111 | (list name-and-options)) 112 | (unless for 113 | (error "You must specify an implementation name.")) 114 | (let ((generic-name (find-symbol (format nil "%~A" name))) 115 | (implementation-arg (copy-symbol '%implementation))) 116 | (unless generic-name 117 | (error "~S does not name an implementation function" name)) 118 | `(defmethod ,generic-name 119 | ,@(when qualifier (list qualifier)) 120 | ,(list* `(,implementation-arg ,for) lambda-list) ,@body)))) 121 | 122 | 123 | ;;; Bootstrap implementations 124 | 125 | (defvar *implementation* nil) 126 | (defclass lisp () ()) 127 | 128 | 129 | ;;; Allegro Common Lisp 130 | 131 | (define-implementation-package :allegro #:ql-allegro 132 | (:documentation 133 | "Allegro Common Lisp - http://www.franz.com/products/allegrocl/") 134 | (:class allegro) 135 | (:reexport-from #:socket 136 | #:make-socket) 137 | (:reexport-from #:excl 138 | #:file-directory-p 139 | #:delete-directory 140 | #:delete-directory-and-files 141 | #:read-vector)) 142 | 143 | 144 | ;;; Armed Bear Common Lisp 145 | 146 | (define-implementation-package :abcl #:ql-abcl 147 | (:documentation 148 | "Armed Bear Common Lisp - http://common-lisp.net/project/armedbear/") 149 | (:class abcl) 150 | (:reexport-from #:ext 151 | #:make-socket 152 | #:get-socket-stream)) 153 | 154 | ;;; Clozure CL 155 | 156 | (define-implementation-package :ccl #:ql-ccl 157 | (:documentation 158 | "Clozure Common Lisp - http://www.clozure.com/clozurecl.html") 159 | (:class ccl) 160 | (:reexport-from #:ccl 161 | #:delete-directory 162 | #:make-socket 163 | #:native-translated-namestring)) 164 | 165 | ;;; CLASP 166 | 167 | (define-implementation-package :clasp #:ql-clasp 168 | (:documentation "CLASP - http://github.com/drmeister/clasp") 169 | (:class clasp) 170 | (:prep 171 | (require 'sockets)) 172 | (:intern #:host-network-address) 173 | (:reexport-from #:si 174 | #:rmdir 175 | #:file-kind) 176 | (:reexport-from #:sb-bsd-sockets 177 | #:get-host-by-name 178 | #:host-ent-address 179 | #:inet-socket 180 | #:socket-connect 181 | #:socket-make-stream)) 182 | 183 | 184 | ;;; GNU CLISP 185 | 186 | (define-implementation-package :clisp #:ql-clisp 187 | (:documentation "GNU CLISP - http://clisp.cons.org/") 188 | (:class clisp) 189 | (:reexport-from #:socket 190 | #:socket-connect) 191 | (:reexport-from #:ext 192 | #:delete-directory 193 | #:rename-directory 194 | #:probe-directory 195 | #:probe-pathname 196 | #:read-byte-sequence)) 197 | 198 | 199 | ;;; CMUCL 200 | 201 | (define-implementation-package :cmu #:ql-cmucl 202 | (:documentation "CMU Common Lisp - http://www.cons.org/cmucl/") 203 | (:class cmucl) 204 | (:reexport-from #:system 205 | #:make-fd-stream) 206 | (:reexport-from #:unix 207 | #:unix-rmdir) 208 | (:reexport-from #:extensions 209 | #:connect-to-inet-socket 210 | #:*gc-verbose*)) 211 | 212 | (defvar ql-cmucl:*gc-verbose*) 213 | 214 | 215 | ;;; Scieneer CL 216 | 217 | (define-implementation-package :scl #:ql-scl 218 | (:documentation "Scieneer Common Lisp - http://www.scieneer.com/scl/") 219 | (:class scl) 220 | (:reexport-from #:system 221 | #:make-fd-stream) 222 | (:reexport-from #:unix 223 | #:unix-rmdir) 224 | (:reexport-from #:extensions 225 | #:connect-to-inet-socket 226 | #:unix-namestring)) 227 | 228 | 229 | ;;; LispWorks 230 | 231 | (define-implementation-package :lispworks #:ql-lispworks 232 | (:documentation "LispWorks - http://www.lispworks.com/") 233 | (:class lispworks) 234 | (:prep 235 | (require "comm")) 236 | (:reexport-from #:lw 237 | #:file-directory-p 238 | #:delete-directory) 239 | (:reexport-from #:comm 240 | #:open-tcp-stream 241 | #:get-host-entry)) 242 | 243 | 244 | ;;; ECL 245 | 246 | (define-implementation-package :ecl #:ql-ecl 247 | (:documentation "ECL - http://ecls.sourceforge.net/") 248 | (:class ecl) 249 | (:prep 250 | (require 'sockets)) 251 | (:intern #:host-network-address) 252 | (:reexport-from #:si 253 | #:rmdir 254 | #:file-kind) 255 | (:reexport-from #:sb-bsd-sockets 256 | #:get-host-by-name 257 | #:host-ent-address 258 | #:inet-socket 259 | #:socket-connect 260 | #:socket-make-stream)) 261 | 262 | ;;; Mezzano 263 | 264 | (define-implementation-package :mezzano #:ql-mezzano 265 | (:documentation "Mezzano Lisp Operating System - https://github.com/froggey/Mezzano") 266 | (:class mezzano) 267 | (:reexport-from #:mezzano.network.tcp 268 | #:tcp-stream-connect)) 269 | 270 | ;;; MKCL 271 | 272 | (define-implementation-package :mkcl #:ql-mkcl 273 | (:documentation "ManKai Common Lisp - http://common-lisp.net/project/mkcl/") 274 | (:class mkcl) 275 | (:prep 276 | (require 'sockets)) 277 | (:intern #:host-network-address) 278 | (:reexport-from #:si 279 | #:rmdir 280 | #:file-kind) 281 | (:reexport-from #:sb-bsd-sockets 282 | #:get-host-by-name 283 | #:host-ent-address 284 | #:inet-socket 285 | #:socket-connect 286 | #:socket-make-stream)) 287 | 288 | 289 | ;;; SBCL 290 | 291 | (define-implementation-package :sbcl #:ql-sbcl 292 | (:class sbcl) 293 | (:documentation 294 | "Steel Bank Common Lisp - http://www.sbcl.org/") 295 | (:prep 296 | (require 'sb-posix) 297 | (require 'sb-bsd-sockets)) 298 | (:intern #:host-network-address) 299 | (:reexport-from #:sb-posix 300 | #:rmdir) 301 | (:reexport-from #:sb-ext 302 | #:compiler-note 303 | #:native-namestring) 304 | (:reexport-from #:sb-bsd-sockets 305 | #:get-host-by-name 306 | #:inet-socket 307 | #:host-ent-address 308 | #:socket-connect 309 | #:socket-make-stream)) 310 | 311 | ;;; Genera 312 | 313 | (define-implementation-package :genera #:ql-genera 314 | (:documentation "Genera - https://github.com/SymbolicsGenera/IssuesAndWiki") 315 | (:class genera) 316 | (:reexport-from #:scl 317 | #:send) 318 | (:reexport-from #:fs 319 | #:delete-directory 320 | #:directory-list 321 | #:file-properties) 322 | (:reexport-from #:tcp 323 | #:open-tcp-stream)) 324 | -------------------------------------------------------------------------------- /quicklisp/local-projects.lisp: -------------------------------------------------------------------------------- 1 | ;;;; local-projects.lisp 2 | 3 | ;;; 4 | ;;; Local project support. 5 | ;;; 6 | ;;; Local projects can be placed in /local-projects/. New 7 | ;;; entries in that directory are automatically scanned for system 8 | ;;; files for use with QL:QUICKLOAD. 9 | ;;; 10 | ;;; This works by keeping a cache of system file pathnames in 11 | ;;; /local-projects/system-index.txt. Whenever the 12 | ;;; timestamp on a local projects directory is newer than the 13 | ;;; timestamp on the system index file, the entire tree is re-scanned 14 | ;;; and cached. 15 | ;;; 16 | ;;; This will pick up system files that are created as a result of 17 | ;;; creating new project directory in a local projects directory, 18 | ;;; e.g. unpacking a tarball or zip file, checking out a project from 19 | ;;; version control, etc. It will NOT pick up a system file that is 20 | ;;; added sometime later in a subdirectory; for that, the 21 | ;;; REGISTER-LOCAL-PROJECTS function is needed to rebuild the system 22 | ;;; file index. 23 | ;;; 24 | ;;; In the event there are multiple systems of the same name in the 25 | ;;; directory tree, the one with the shortest pathname namestring is 26 | ;;; used. This is intended to ignore stuff like _darcs pristine 27 | ;;; directories. 28 | ;;; 29 | ;;; Work in progress! 30 | ;;; 31 | 32 | (in-package #:quicklisp-client) 33 | 34 | (defparameter *local-project-directories* 35 | (list (qmerge "local-projects/")) 36 | "The default local projects directories.") 37 | 38 | (defun system-index-file (pathname) 39 | "Return the system index file for the directory PATHNAME." 40 | (merge-pathnames "system-index.txt" pathname)) 41 | 42 | (defun matching-directory-files (directory fun) 43 | (let ((result '())) 44 | (map-directory-tree directory 45 | (lambda (file) 46 | (when (funcall fun file) 47 | (push file result)))) 48 | result)) 49 | 50 | (defun local-project-system-files (pathname) 51 | "Return a list of system files under PATHNAME." 52 | (let ((files (matching-directory-files pathname 53 | (lambda (file) 54 | (equalp (pathname-type file) 55 | "asd"))))) 56 | (setf files (sort files 57 | #'string< 58 | :key #'namestring)) 59 | (stable-sort files 60 | #'< 61 | :key (lambda (file) 62 | (length (namestring file)))))) 63 | 64 | (defun make-system-index (pathname) 65 | "Create a system index file for all system files under 66 | PATHNAME. Current format is one native namestring per line." 67 | (setf pathname (truename pathname)) 68 | (with-open-file (stream (system-index-file pathname) 69 | :direction :output 70 | :if-exists :rename-and-delete) 71 | (dolist (system-file (local-project-system-files pathname)) 72 | (let ((system-path (enough-namestring system-file pathname))) 73 | (write-line (native-namestring system-path) stream))) 74 | (probe-file stream))) 75 | 76 | (defun find-valid-system-index (pathname) 77 | "Find a valid system index file for PATHNAME; one that both exists 78 | and has a newer timestamp than PATHNAME." 79 | (let* ((file (system-index-file pathname)) 80 | (probed (probe-file file))) 81 | (when (and probed 82 | (<= (directory-write-date pathname) 83 | (file-write-date probed))) 84 | probed))) 85 | 86 | (defun ensure-system-index (pathname) 87 | "Find or create a system index file for PATHNAME." 88 | (or (find-valid-system-index pathname) 89 | (make-system-index pathname))) 90 | 91 | (defun find-system-in-index (system index-file) 92 | "If any system pathname in INDEX-FILE has a pathname-name matching 93 | SYSTEM, return its full pathname." 94 | (with-open-file (stream index-file) 95 | (loop for namestring = (read-line stream nil) 96 | while namestring 97 | when (string= system (pathname-name namestring)) 98 | return (or (probe-file (merge-pathnames namestring index-file)) 99 | ;; If the indexed .asd file doesn't exist anymore 100 | ;; then regenerate the index and restart the search. 101 | (find-system-in-index system (make-system-index (directory-namestring index-file))))))) 102 | 103 | (defun local-projects-searcher (system-name) 104 | "This function is added to ASDF:*SYSTEM-DEFINITION-SEARCH-FUNCTIONS* 105 | to use the local project directories and cache to find systems." 106 | (dolist (directory *local-project-directories*) 107 | (when (probe-directory directory) 108 | (let ((system-index (ensure-system-index directory))) 109 | (when system-index 110 | (let ((system (find-system-in-index system-name system-index))) 111 | (when system 112 | (return system)))))))) 113 | 114 | (defun list-local-projects () 115 | "Return a list of pathnames to local project system files." 116 | (let ((result (make-array 16 :fill-pointer 0 :adjustable t)) 117 | (seen (make-hash-table :test 'equal))) 118 | (dolist (directory *local-project-directories* 119 | (coerce result 'list)) 120 | (let ((index (ensure-system-index directory))) 121 | (when index 122 | (with-open-file (stream index) 123 | (loop for line = (read-line stream nil) 124 | while line do 125 | (let ((pathname (merge-pathnames line index))) 126 | (unless (gethash (pathname-name pathname) seen) 127 | (setf (gethash (pathname-name pathname) seen) t) 128 | (vector-push-extend (merge-pathnames line index) 129 | result)))))))))) 130 | 131 | (defun register-local-projects () 132 | "Force a scan of the local projects directories to create the system 133 | file index." 134 | (map nil 'make-system-index *local-project-directories*)) 135 | 136 | (defun list-local-systems () 137 | "Return a list of local project system names." 138 | (mapcar #'pathname-name (list-local-projects))) 139 | -------------------------------------------------------------------------------- /quicklisp/minitar.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:ql-minitar) 2 | 3 | (defconstant +block-size+ 512) 4 | (defconstant +space-code+ 32) 5 | (defconstant +newline-code+ 10) 6 | (defconstant +equals-code+ 61) 7 | 8 | (defun make-block-buffer () 9 | (make-array +block-size+ :element-type '(unsigned-byte 8) :initial-element 0)) 10 | 11 | (defun skip-n-blocks (n stream) 12 | (let ((block (make-block-buffer))) 13 | (dotimes (i n) 14 | (read-sequence block stream)))) 15 | 16 | (defun read-octet-vector (length stream) 17 | (let ((block (make-block-buffer)) 18 | (vector (make-array length :element-type '(unsigned-byte 8))) 19 | (offset 0) 20 | (block-count (ceiling length +block-size+))) 21 | (dotimes (i block-count) 22 | (read-sequence block stream) 23 | (replace vector block :start1 offset) 24 | (incf offset +block-size+)) 25 | vector)) 26 | 27 | 28 | (defun decode-pax-header-record (vector offset) 29 | "Decode VECTOR as pax extended header data. Returns the keyword and 30 | value it specifies as multiple values." 31 | ;; Vector format is: "%d %s=%s\n", , , 32 | ;; See http://pubs.opengroup.org/onlinepubs/009695399/utilities/pax.html 33 | (let* ((length-start offset) 34 | (length-end (position +space-code+ vector :start length-start)) 35 | (length-string (ascii-subseq vector length-start length-end)) 36 | (length (parse-integer length-string)) 37 | (keyword-start (1+ length-end)) 38 | (keyword-end (position +equals-code+ vector :start keyword-start)) 39 | (keyword (ascii-subseq vector keyword-start keyword-end)) 40 | (value-start (1+ keyword-end)) 41 | (value-end (1- (+ offset length))) 42 | (value (ascii-subseq vector value-start value-end))) 43 | (values keyword value (+ offset length)))) 44 | 45 | (defun decode-pax-header (vector) 46 | "Decode VECTOR as a pax header and return it as an alist." 47 | (let ((header nil) 48 | (offset 0) 49 | (length (length vector))) 50 | (loop 51 | (when (<= length offset) 52 | (return header)) 53 | (multiple-value-bind (keyword value new-offset) 54 | (decode-pax-header-record vector offset) 55 | (setf header (acons keyword value header)) 56 | (setf offset new-offset))))) 57 | 58 | (defun pax-header-path (vector) 59 | "Decode VECTOR as a pax header and return its 'path' value, if 60 | any." 61 | (let ((header-alist (decode-pax-header vector))) 62 | (cdr (assoc "path" header-alist :test 'equal)))) 63 | 64 | (defun ascii-subseq (vector start end) 65 | (let ((string (make-string (- end start)))) 66 | (loop for i from 0 67 | for j from start below end 68 | do (setf (char string i) (code-char (aref vector j)))) 69 | string)) 70 | 71 | (defun block-asciiz-string (block start length) 72 | (let* ((end (+ start length)) 73 | (eos (or (position 0 block :start start :end end) 74 | end))) 75 | (ascii-subseq block start eos))) 76 | 77 | (defun prefix (header) 78 | (when (plusp (aref header 345)) 79 | (block-asciiz-string header 345 155))) 80 | 81 | (defun name (header) 82 | (block-asciiz-string header 0 100)) 83 | 84 | (defun payload-size (header) 85 | (values (parse-integer (block-asciiz-string header 124 12) :radix 8))) 86 | 87 | (defun nth-block (n file) 88 | (with-open-file (stream file :element-type '(unsigned-byte 8)) 89 | (let ((block (make-block-buffer))) 90 | (skip-n-blocks (1- n) stream) 91 | (read-sequence block stream) 92 | block))) 93 | 94 | (defun payload-type (code) 95 | (case code 96 | (0 :file) 97 | (48 :file) 98 | (50 :symlink) 99 | (76 :long-name) 100 | (53 :directory) 101 | (103 :global-header) 102 | (120 :pax-extended-header) 103 | (t :unsupported))) 104 | 105 | (defun full-path (header) 106 | (let ((prefix (prefix header)) 107 | (name (name header))) 108 | (if prefix 109 | (format nil "~A/~A" prefix name) 110 | name))) 111 | 112 | (defun save-file (file size stream) 113 | (multiple-value-bind (full-blocks partial) 114 | (truncate size +block-size+) 115 | (ensure-directories-exist file) 116 | (with-open-file (outstream file 117 | :direction :output 118 | :if-exists :supersede 119 | :element-type '(unsigned-byte 8)) 120 | (let ((block (make-block-buffer))) 121 | (dotimes (i full-blocks) 122 | (read-sequence block stream) 123 | (write-sequence block outstream)) 124 | (when (plusp partial) 125 | (read-sequence block stream) 126 | (write-sequence block outstream :end partial)))))) 127 | 128 | (defun gnu-long-name (size stream) 129 | ;; GNU long names are simply the filename (null terminated) packed into the 130 | ;; payload. 131 | (let ((payload (read-octet-vector size stream))) 132 | (ascii-subseq payload 0 (1- size)))) 133 | 134 | (defun unpack-tarball (tarfile &key (directory *default-pathname-defaults*)) 135 | (let ((block (make-block-buffer)) 136 | (extended-path nil)) 137 | (with-open-file (stream tarfile :element-type '(unsigned-byte 8)) 138 | (loop 139 | (let ((size (read-sequence block stream))) 140 | (when (zerop size) 141 | (return)) 142 | (unless (= size +block-size+) 143 | (error "Bad size on tarfile")) 144 | (when (every #'zerop block) 145 | (return)) 146 | (let* ((payload-code (aref block 156)) 147 | (payload-type (payload-type payload-code)) 148 | (tar-path (or (shiftf extended-path nil) 149 | (full-path block))) 150 | (full-path (merge-pathnames tar-path directory)) 151 | (payload-size (payload-size block)) 152 | (block-count (ceiling (payload-size block) +block-size+))) 153 | (case payload-type 154 | (:file 155 | (save-file full-path payload-size stream)) 156 | (:directory 157 | (ensure-directories-exist full-path)) 158 | ((:symlink :global-header) 159 | ;; These block types aren't required for Quicklisp archives 160 | (skip-n-blocks block-count stream)) 161 | (:long-name 162 | (setf extended-path (gnu-long-name payload-size stream))) 163 | (:pax-extended-header 164 | (let* ((pax-header-data (read-octet-vector payload-size stream)) 165 | (path (pax-header-path pax-header-data))) 166 | (when path 167 | (setf extended-path path)))) 168 | (t 169 | (warn "Unknown tar block payload code -- ~D" payload-code) 170 | (skip-n-blocks block-count stream))))))))) 171 | 172 | (defun contents (tarfile) 173 | (let ((block (make-block-buffer)) 174 | (result '())) 175 | (with-open-file (stream tarfile :element-type '(unsigned-byte 8)) 176 | (loop 177 | (let ((size (read-sequence block stream))) 178 | (when (zerop size) 179 | (return (nreverse result))) 180 | (unless (= size +block-size+) 181 | (error "Bad size on tarfile")) 182 | (when (every #'zerop block) 183 | (return (nreverse result))) 184 | (let* ((payload-type (payload-type (aref block 156))) 185 | (tar-path (full-path block)) 186 | (payload-size (payload-size block))) 187 | (skip-n-blocks (ceiling payload-size +block-size+) stream) 188 | (case payload-type 189 | (:file 190 | (push tar-path result)) 191 | (:directory 192 | (push tar-path result))))))))) 193 | -------------------------------------------------------------------------------- /quicklisp/misc.lisp: -------------------------------------------------------------------------------- 1 | ;;;; misc.lisp 2 | 3 | (in-package #:quicklisp-client) 4 | 5 | ;;; 6 | ;;; This stuff will probably end up somewhere else. 7 | ;;; 8 | 9 | (defun use-only-quicklisp-systems () 10 | (asdf:initialize-source-registry 11 | '(:source-registry :ignore-inherited-configuration)) 12 | (asdf:map-systems 'asdf:clear-system) 13 | t) 14 | 15 | (defun who-depends-on (system-name) 16 | "Return a list of names of systems that depend on SYSTEM-NAME." 17 | (setf system-name (string-downcase system-name)) 18 | (loop for system in (provided-systems t) 19 | when (member system-name (required-systems system) :test 'string=) 20 | collect (name system))) 21 | -------------------------------------------------------------------------------- /quicklisp/network.lisp: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Low-level networking implementations 3 | ;;; 4 | 5 | (in-package #:ql-network) 6 | 7 | (definterface host-address (host) 8 | (:implementation t 9 | host) 10 | (:implementation sbcl 11 | (ql-sbcl:host-ent-address (ql-sbcl:get-host-by-name host)))) 12 | 13 | (definterface open-connection (host port) 14 | (:documentation "Open and return a network connection to HOST on the 15 | given PORT.") 16 | (:implementation t 17 | (declare (ignore host port)) 18 | (error "Sorry, quicklisp in implementation ~S is not supported yet." 19 | (lisp-implementation-type))) 20 | (:implementation allegro 21 | (ql-allegro:make-socket :remote-host host 22 | :remote-port port)) 23 | (:implementation abcl 24 | (let ((socket (ql-abcl:make-socket host port))) 25 | (ql-abcl:get-socket-stream socket :element-type '(unsigned-byte 8)))) 26 | (:implementation ccl 27 | (ql-ccl:make-socket :remote-host host 28 | :remote-port port)) 29 | (:implementation clasp 30 | (let* ((endpoint (ql-clasp:host-ent-address 31 | (ql-clasp:get-host-by-name host))) 32 | (socket (make-instance 'ql-clasp:inet-socket 33 | :protocol :tcp 34 | :type :stream))) 35 | (ql-clasp:socket-connect socket endpoint port) 36 | (ql-clasp:socket-make-stream socket 37 | :element-type '(unsigned-byte 8) 38 | :input t 39 | :output t 40 | :buffering :full))) 41 | (:implementation clisp 42 | (ql-clisp:socket-connect port host :element-type '(unsigned-byte 8))) 43 | (:implementation cmucl 44 | (let ((fd (ql-cmucl:connect-to-inet-socket host port))) 45 | (ql-cmucl:make-fd-stream fd 46 | :element-type '(unsigned-byte 8) 47 | :binary-stream-p t 48 | :input t 49 | :output t))) 50 | (:implementation scl 51 | (let ((fd (ql-scl:connect-to-inet-socket host port))) 52 | (ql-scl:make-fd-stream fd 53 | :element-type '(unsigned-byte 8) 54 | :input t 55 | :output t))) 56 | (:implementation ecl 57 | (let* ((endpoint (ql-ecl:host-ent-address 58 | (ql-ecl:get-host-by-name host))) 59 | (socket (make-instance 'ql-ecl:inet-socket 60 | :protocol :tcp 61 | :type :stream))) 62 | (ql-ecl:socket-connect socket endpoint port) 63 | (ql-ecl:socket-make-stream socket 64 | :element-type '(unsigned-byte 8) 65 | :input t 66 | :output t 67 | :buffering :full))) 68 | (:implementation mezzano 69 | (ql-mezzano:tcp-stream-connect host port 70 | :element-type '(unsigned-byte 8))) 71 | (:implementation mkcl 72 | (let* ((endpoint (ql-mkcl:host-ent-address 73 | (ql-mkcl:get-host-by-name host))) 74 | (socket (make-instance 'ql-mkcl:inet-socket 75 | :protocol :tcp 76 | :type :stream))) 77 | (ql-mkcl:socket-connect socket endpoint port) 78 | (ql-mkcl:socket-make-stream socket 79 | :element-type '(unsigned-byte 8) 80 | :input t 81 | :output t 82 | :buffering :full))) 83 | (:implementation lispworks 84 | (ql-lispworks:open-tcp-stream host port 85 | :direction :io 86 | :errorp t 87 | :read-timeout nil 88 | :element-type '(unsigned-byte 8) 89 | :timeout 5)) 90 | (:implementation sbcl 91 | (let* ((endpoint (ql-sbcl:host-ent-address 92 | (ql-sbcl:get-host-by-name host))) 93 | (socket (make-instance 'ql-sbcl:inet-socket 94 | :protocol :tcp 95 | :type :stream))) 96 | (ql-sbcl:socket-connect socket endpoint port) 97 | (ql-sbcl:socket-make-stream socket 98 | :element-type '(unsigned-byte 8) 99 | :input t 100 | :output t 101 | :buffering :full))) 102 | (:implementation genera 103 | (ql-genera:open-tcp-stream host port nil :direction :io :characters nil))) 104 | 105 | (definterface read-octets (buffer connection) 106 | (:documentation "Read from CONNECTION into BUFFER. Returns the 107 | number of octets read.") 108 | (:implementation t 109 | (read-sequence buffer connection)) 110 | (:implementation allegro 111 | (ql-allegro:read-vector buffer connection)) 112 | (:implementation clisp 113 | (ql-clisp:read-byte-sequence buffer connection 114 | :no-hang nil 115 | :interactive t))) 116 | 117 | (definterface write-octets (buffer connection) 118 | (:documentation "Write the contents of BUFFER to CONNECTION.") 119 | (:implementation t 120 | (write-sequence buffer connection) 121 | (finish-output connection))) 122 | 123 | (definterface close-connection (connection) 124 | (:implementation t 125 | (ignore-errors (close connection)))) 126 | 127 | (definterface call-with-connection (host port fun) 128 | (:documentation "Establish a network connection to HOST on PORT and 129 | call FUN with that connection as the only argument. Unconditionally 130 | closes the connection afterwareds via CLOSE-CONNECTION in an 131 | unwind-protect. See also WITH-CONNECTION.") 132 | (:implementation t 133 | (let ((connection nil)) 134 | (unwind-protect 135 | (progn 136 | (setf connection (open-connection host port)) 137 | (funcall fun connection)) 138 | (when connection 139 | (close-connection connection)))))) 140 | 141 | (defmacro with-connection ((connection host port) &body body) 142 | `(call-with-connection ,host ,port (lambda (,connection) ,@body))) 143 | -------------------------------------------------------------------------------- /quicklisp/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; package.lisp 2 | 3 | (defpackage #:ql-util 4 | (:documentation 5 | "Utility functions used in various places.") 6 | (:use #:cl) 7 | (:export #:write-line-to-file 8 | #:without-prompting 9 | #:press-enter-to-continue 10 | #:replace-file 11 | #:copy-file 12 | #:delete-file-if-exists 13 | #:ensure-file-exists 14 | #:split-spaces 15 | #:first-line 16 | #:file-size 17 | #:safely-read 18 | #:safely-read-file 19 | #:make-versions-url 20 | #:with-temporary-file)) 21 | 22 | (defpackage #:ql-setup 23 | (:documentation 24 | "Functions and variables initialized early in the Quicklisp client 25 | configuration.") 26 | (:use #:cl) 27 | (:export #:qmerge 28 | #:qenough 29 | #:*quicklisp-home*)) 30 | 31 | (defpackage #:ql-config 32 | (:documentation 33 | "Getting and setting persistent configuration values.") 34 | (:use #:cl #:ql-util #:ql-setup) 35 | (:export #:config-value)) 36 | 37 | (defpackage #:ql-impl 38 | (:documentation 39 | "Configuration of implementation-specific packages and interfaces.") 40 | (:use #:cl) 41 | (:export #:*implementation*) 42 | (:export #:definterface 43 | #:defimplementation 44 | #:show-interfaces) 45 | (:export #:lisp 46 | #:abcl 47 | #:allegro 48 | #:ccl 49 | #:clasp 50 | #:clisp 51 | #:cmucl 52 | #:cormanlisp 53 | #:ecl 54 | #:gcl 55 | #:genera 56 | #:lispworks 57 | #:mezzano 58 | #:mkcl 59 | #:scl 60 | #:sbcl)) 61 | 62 | (defpackage #:ql-impl-util 63 | (:documentation 64 | "Utility functions that require implementation-specific 65 | functionality.") 66 | (:use #:cl #:ql-impl) 67 | (:export #:call-with-quiet-compilation 68 | #:add-to-init-file 69 | #:rename-directory 70 | #:delete-directory 71 | #:probe-directory 72 | #:directory-entries 73 | #:delete-directory-tree 74 | #:map-directory-tree 75 | #:native-namestring 76 | #:directory-write-date)) 77 | 78 | (defpackage #:ql-network 79 | (:documentation 80 | "Simple, low-level network access.") 81 | (:use #:cl #:ql-impl) 82 | (:export #:open-connection 83 | #:write-octets 84 | #:read-octets 85 | #:close-connection 86 | #:with-connection)) 87 | 88 | (defpackage #:ql-progress 89 | (:documentation 90 | "Displaying a progress bar.") 91 | (:use #:cl) 92 | (:export #:make-progress-bar 93 | #:start-display 94 | #:update-progress 95 | #:finish-display)) 96 | 97 | (defpackage #:ql-http 98 | (:documentation 99 | "A simple HTTP client.") 100 | (:use #:cl #:ql-network #:ql-progress #:ql-config) 101 | (:export #:*proxy-url* 102 | #:fetch 103 | #:http-fetch 104 | #:*fetch-scheme-functions* 105 | #:scheme 106 | #:hostname 107 | #:port 108 | #:path 109 | #:url 110 | #:*maximum-redirects* 111 | #:*default-url-defaults*) 112 | (:export #:fetch-error 113 | #:unexpected-http-status 114 | #:unexpected-http-status-code 115 | #:unexpected-http-status-url 116 | #:too-many-redirects 117 | #:too-many-redirects-url 118 | #:too-many-redirects-count)) 119 | 120 | (defpackage #:ql-minitar 121 | (:documentation 122 | "A simple implementation of unpacking the 'tar' file format.") 123 | (:use #:cl) 124 | (:export #:unpack-tarball)) 125 | 126 | (defpackage #:ql-gunzipper 127 | (:documentation 128 | "An implementation of gunzip.") 129 | (:use #:cl) 130 | (:export #:gunzip)) 131 | 132 | (defpackage #:ql-cdb 133 | (:documentation 134 | "Read and write CDB files; code adapted from ZCDB.") 135 | (:use #:cl) 136 | (:export #:lookup 137 | #:map-cdb 138 | #:convert-index-file)) 139 | 140 | (defpackage #:ql-dist 141 | (:documentation 142 | "Generic functions, variables, and classes for interacting with the 143 | dist system. Documented, exported symbols are intended for public 144 | use.") 145 | (:use #:cl 146 | #:ql-util 147 | #:ql-http 148 | #:ql-setup 149 | #:ql-gunzipper 150 | #:ql-minitar) 151 | (:intern #:dist-version 152 | #:dist-url) 153 | (:import-from #:ql-impl-util 154 | #:delete-directory-tree 155 | #:directory-entries 156 | #:probe-directory) 157 | ;; Install/enable protocol 158 | (:export #:installedp 159 | #:install 160 | #:uninstall 161 | #:ensure-installed 162 | #:enabledp 163 | #:enable 164 | #:disable) 165 | ;; Preference protocol 166 | (:export #:preference 167 | #:preference-file 168 | #:preference-parent 169 | #:forget-preference) 170 | ;; Generic 171 | (:export #:all-dists 172 | #:canonical-distinfo-url 173 | #:enabled-dists 174 | #:find-dist 175 | #:find-dist-or-lose 176 | #:find-system 177 | #:find-release 178 | #:dist 179 | #:system 180 | #:release 181 | #:base-directory 182 | #:relative-to 183 | #:metadata-name 184 | #:install-metadata-file 185 | #:short-description 186 | #:provided-releases 187 | #:provided-systems 188 | #:installed-releases 189 | #:installed-systems 190 | #:name) 191 | ;; Dists 192 | (:export #:dist 193 | #:dist-merge 194 | #:find-system-in-dist 195 | #:find-release-in-dist 196 | #:system-index-url 197 | #:release-index-url 198 | #:available-versions-url 199 | #:available-versions 200 | #:version 201 | #:subscription-url 202 | #:new-version-available-p 203 | #:dist-difference 204 | #:fetch-dist 205 | #:initialize-release-index 206 | #:initialize-system-index 207 | #:with-consistent-dists) 208 | ;; Dist updates 209 | (:export #:available-update 210 | #:update-release-differences 211 | #:show-update-report 212 | #:update-in-place 213 | #:install-dist 214 | #:subscription-inhibition-file 215 | #:inhibit-subscription 216 | #:uninhibit-subscription 217 | #:subscription-inhibited-p 218 | #:subscription-unavailable 219 | #:subscribedp 220 | #:subscribe 221 | #:unsubscribe) 222 | ;; Releases 223 | (:export #:release 224 | #:project-name 225 | #:system-files 226 | #:archive-url 227 | #:archive-size 228 | #:ensure-archive-file 229 | #:archive-content-sha1 230 | #:archive-md5 231 | #:prefix 232 | #:local-archive-file 233 | #:ensure-local-archive-file 234 | #:check-local-archive-file 235 | #:invalid-local-archive 236 | #:invalid-local-archive-file 237 | #:invalid-local-archive-release 238 | #:missing-local-archive 239 | #:badly-sized-local-archive 240 | #:delete-and-retry) 241 | ;; Systems 242 | (:export #:dist 243 | #:release 244 | #:preference 245 | #:system-file-name 246 | #:required-systems) 247 | ;; Misc 248 | (:export #:standard-dist-enumeration-function 249 | #:*dist-enumeration-functions* 250 | #:find-asdf-system-file 251 | #:system-definition-searcher 252 | #:system-apropos 253 | #:system-apropos-list 254 | #:dependency-tree 255 | #:clean 256 | #:unknown-dist)) 257 | 258 | (defpackage #:ql-dist-user 259 | (:documentation 260 | "A package that uses QL-DIST; useful for playing around in without 261 | clobbering any QL-DIST internals.") 262 | (:use #:cl 263 | #:ql-dist)) 264 | 265 | (defpackage #:ql-bundle 266 | (:documentation 267 | "A package for supporting the QL:BUNDLE-SYSTEMS function.") 268 | (:use #:cl #:ql-dist #:ql-impl-util) 269 | (:shadow #:find-system 270 | #:find-release) 271 | (:export #:bundle 272 | #:requested-systems 273 | #:ensure-system 274 | #:ensure-release 275 | #:write-bundle 276 | #:add-systems-recursively 277 | #:object-not-found 278 | #:system-not-found 279 | #:system-not-found-system 280 | #:release-not-found 281 | #:bundle-directory-exists 282 | #:bundle-directory-exists-directory)) 283 | 284 | (defpackage #:quicklisp-client 285 | (:documentation 286 | "The Quicklisp client package, intended for end-user Quicklisp 287 | commands and configuration parameters.") 288 | (:nicknames #:quicklisp #:ql) 289 | (:use #:cl 290 | #:ql-util 291 | #:ql-impl-util 292 | #:ql-dist 293 | #:ql-http 294 | #:ql-setup 295 | #:ql-config 296 | #:ql-minitar 297 | #:ql-gunzipper) 298 | (:shadow #:uninstall) 299 | (:shadowing-import-from #:ql-dist 300 | #:dist-version 301 | #:dist-url) 302 | (:export #:dist-version 303 | #:dist-url) 304 | (:export #:quickload 305 | #:*quickload-prompt* 306 | #:*quickload-verbose* 307 | #:*quickload-explain* 308 | #:system-not-found 309 | #:system-not-found-name 310 | #:uninstall 311 | #:uninstall-dist 312 | #:qmerge 313 | #:*quicklisp-home* 314 | #:*initial-dist-url* 315 | #:*proxy-url* 316 | #:config-value 317 | #:setup 318 | #:provided-systems 319 | #:system-apropos 320 | #:system-apropos-list 321 | #:system-list 322 | #:client-version 323 | #:client-url 324 | #:available-client-versions 325 | #:install-client 326 | #:update-client 327 | #:update-dist 328 | #:update-all-dists 329 | #:available-dist-versions 330 | #:add-to-init-file 331 | #:use-only-quicklisp-systems 332 | #:write-asdf-manifest-file 333 | #:where-is-system 334 | #:help 335 | #:register-local-projects 336 | #:local-projects-searcher 337 | #:*local-project-directories* 338 | #:list-local-projects 339 | #:list-local-systems 340 | #:who-depends-on 341 | #:bundle-systems)) 342 | 343 | (in-package #:quicklisp-client) 344 | -------------------------------------------------------------------------------- /quicklisp/progress.lisp: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; A text progress bar 3 | ;;; 4 | 5 | (in-package #:ql-progress) 6 | 7 | (defclass progress-bar () 8 | ((start-time 9 | :initarg :start-time 10 | :accessor start-time) 11 | (end-time 12 | :initarg :end-time 13 | :accessor end-time) 14 | (progress-character 15 | :initarg :progress-character 16 | :accessor progress-character) 17 | (character-count 18 | :initarg :character-count 19 | :accessor character-count 20 | :documentation "How many characters wide is the progress bar?") 21 | (characters-so-far 22 | :initarg :characters-so-far 23 | :accessor characters-so-far) 24 | (update-interval 25 | :initarg :update-interval 26 | :accessor update-interval 27 | :documentation "Update the progress bar display after this many 28 | internal-time units.") 29 | (last-update-time 30 | :initarg :last-update-time 31 | :accessor last-update-time 32 | :documentation "The display was last updated at this time.") 33 | (total 34 | :initarg :total 35 | :accessor total 36 | :documentation "The total number of units tracked by this progress bar.") 37 | (progress 38 | :initarg :progress 39 | :accessor progress 40 | :documentation "How far in the progress are we?") 41 | (pending 42 | :initarg :pending 43 | :accessor pending 44 | :documentation "How many raw units should be tracked in the next 45 | display update?")) 46 | (:default-initargs 47 | :progress-character #\= 48 | :character-count 50 49 | :characters-so-far 0 50 | :update-interval (floor internal-time-units-per-second 4) 51 | :last-update-time 0 52 | :total 0 53 | :progress 0 54 | :pending 0)) 55 | 56 | (defgeneric start-display (progress-bar)) 57 | (defgeneric update-progress (progress-bar unit-count)) 58 | (defgeneric update-display (progress-bar)) 59 | (defgeneric finish-display (progress-bar)) 60 | (defgeneric elapsed-time (progress-bar)) 61 | (defgeneric units-per-second (progress-bar)) 62 | 63 | (defmethod start-display (progress-bar) 64 | (setf (last-update-time progress-bar) (get-internal-real-time)) 65 | (setf (start-time progress-bar) (get-internal-real-time)) 66 | (fresh-line) 67 | (finish-output)) 68 | 69 | (defmethod update-display (progress-bar) 70 | (incf (progress progress-bar) (pending progress-bar)) 71 | (setf (pending progress-bar) 0) 72 | (setf (last-update-time progress-bar) (get-internal-real-time)) 73 | (let* ((showable (floor (character-count progress-bar) 74 | (/ (total progress-bar) (progress progress-bar)))) 75 | (needed (- showable (characters-so-far progress-bar)))) 76 | (setf (characters-so-far progress-bar) showable) 77 | (dotimes (i needed) 78 | (write-char (progress-character progress-bar))) 79 | (finish-output))) 80 | 81 | (defmethod update-progress (progress-bar unit-count) 82 | (incf (pending progress-bar) unit-count) 83 | (let ((now (get-internal-real-time))) 84 | (when (< (update-interval progress-bar) 85 | (- now (last-update-time progress-bar))) 86 | (update-display progress-bar)))) 87 | 88 | (defmethod finish-display (progress-bar) 89 | (update-display progress-bar) 90 | (setf (end-time progress-bar) (get-internal-real-time)) 91 | (terpri) 92 | (format t "~:D bytes in ~$ seconds (~$KB/sec)~%" 93 | (total progress-bar) 94 | (elapsed-time progress-bar) 95 | (/ (units-per-second progress-bar) 1024)) 96 | (finish-output)) 97 | 98 | (defmethod elapsed-time (progress-bar) 99 | (/ (- (end-time progress-bar) (start-time progress-bar)) 100 | internal-time-units-per-second)) 101 | 102 | (defmethod units-per-second (progress-bar) 103 | (if (plusp (elapsed-time progress-bar)) 104 | (/ (total progress-bar) (elapsed-time progress-bar)) 105 | 0)) 106 | 107 | (defun kb/sec (progress-bar) 108 | (/ (units-per-second progress-bar) 1024)) 109 | 110 | 111 | 112 | (defparameter *uncertain-progress-chars* "?") 113 | 114 | (defclass uncertain-size-progress-bar (progress-bar) 115 | ((progress-char-index 116 | :initarg :progress-char-index 117 | :accessor progress-char-index) 118 | (units-per-char 119 | :initarg :units-per-char 120 | :accessor units-per-char)) 121 | (:default-initargs 122 | :total 0 123 | :progress-char-index 0 124 | :units-per-char (floor (expt 1024 2) 50))) 125 | 126 | (defmethod update-progress :after ((progress-bar uncertain-size-progress-bar) 127 | unit-count) 128 | (incf (total progress-bar) unit-count)) 129 | 130 | (defmethod progress-character ((progress-bar uncertain-size-progress-bar)) 131 | (let ((index (progress-char-index progress-bar))) 132 | (prog1 133 | (char *uncertain-progress-chars* index) 134 | (setf (progress-char-index progress-bar) 135 | (mod (1+ index) (length *uncertain-progress-chars*)))))) 136 | 137 | (defmethod update-display ((progress-bar uncertain-size-progress-bar)) 138 | (setf (last-update-time progress-bar) (get-internal-real-time)) 139 | (multiple-value-bind (chars pend) 140 | (floor (pending progress-bar) (units-per-char progress-bar)) 141 | (setf (pending progress-bar) pend) 142 | (dotimes (i chars) 143 | (write-char (progress-character progress-bar)) 144 | (incf (characters-so-far progress-bar)) 145 | (when (<= (character-count progress-bar) 146 | (characters-so-far progress-bar)) 147 | (terpri) 148 | (setf (characters-so-far progress-bar) 0) 149 | (finish-output))) 150 | (finish-output))) 151 | 152 | (defun make-progress-bar (total) 153 | (if (or (not total) (zerop total)) 154 | (make-instance 'uncertain-size-progress-bar) 155 | (make-instance 'progress-bar :total total))) 156 | 157 | -------------------------------------------------------------------------------- /quicklisp/quicklisp.asd: -------------------------------------------------------------------------------- 1 | ;;;; quicklisp.asd 2 | 3 | (defpackage #:ql-info 4 | (:export #:*version*)) 5 | 6 | (defvar ql-info:*version* 7 | (with-open-file (stream (merge-pathnames "version.txt" *load-truename*)) 8 | (read-line stream))) 9 | 10 | (asdf:defsystem #:quicklisp 11 | :description "The Quicklisp client application." 12 | :author "Zach Beane " 13 | :license "BSD-style" 14 | :serial t 15 | :version #.(remove-if-not #'digit-char-p ql-info:*version*) 16 | :components ((:file "package") 17 | (:file "utils") 18 | (:file "config") 19 | (:file "impl") 20 | (:file "impl-util") 21 | (:file "network") 22 | (:file "progress") 23 | (:file "http") 24 | (:file "deflate") 25 | (:file "minitar") 26 | (:file "cdb") 27 | (:file "dist") 28 | (:file "setup") 29 | (:file "client") 30 | (:file "fetch-gzipped") 31 | (:file "client-info") 32 | (:file "client-update") 33 | (:file "dist-update") 34 | (:file "misc") 35 | (:file "local-projects") 36 | (:file "bundle"))) 37 | -------------------------------------------------------------------------------- /quicklisp/setup.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:quicklisp) 2 | 3 | (defun show-wrapped-list (words &key (indent 4) (margin 60)) 4 | (let ((*print-right-margin* margin) 5 | (*print-pretty* t) 6 | (*print-escape* nil) 7 | (prefix (make-string indent :initial-element #\Space))) 8 | ;; Genera doesn't implement pprint-logical-block et al... 9 | #-genera (pprint-logical-block (nil words :per-line-prefix prefix) 10 | (pprint-fill *standard-output* (sort (copy-seq words) #'string<) nil)) 11 | #+genera (format *standard-output* "~&~A~{~S ~}~%" prefix (sort (copy-seq words) #'string<)) 12 | (fresh-line) 13 | (finish-output))) 14 | 15 | (defun recursively-install (name) 16 | (labels ((recurse (name) 17 | (let ((system (find-system name))) 18 | (unless system 19 | (error "Unknown system ~S" name)) 20 | (ensure-installed system) 21 | (mapc #'recurse (required-systems system)) 22 | name))) 23 | (with-consistent-dists 24 | (recurse name)))) 25 | 26 | (defclass load-strategy () 27 | ((name 28 | :initarg :name 29 | :accessor name) 30 | (asdf-systems 31 | :initarg :asdf-systems 32 | :accessor asdf-systems) 33 | (quicklisp-systems 34 | :initarg :quicklisp-systems 35 | :accessor quicklisp-systems))) 36 | 37 | (defmethod print-object ((strategy load-strategy) stream) 38 | (print-unreadable-object (strategy stream :type t) 39 | (format stream "~S (~D asdf, ~D quicklisp)" 40 | (name strategy) 41 | (length (asdf-systems strategy)) 42 | (length (quicklisp-systems strategy))))) 43 | 44 | (defgeneric quicklisp-releases (strategy) 45 | (:method (strategy) 46 | (remove-duplicates (mapcar 'release (quicklisp-systems strategy))))) 47 | 48 | (defgeneric quicklisp-release-table (strategy) 49 | (:method ((strategy load-strategy)) 50 | (let ((table (make-hash-table))) 51 | (dolist (system (quicklisp-systems strategy)) 52 | (push system (gethash (release system) table nil))) 53 | table))) 54 | 55 | (define-condition system-not-found (error) 56 | ((name 57 | :initarg :name 58 | :reader system-not-found-name)) 59 | (:report (lambda (condition stream) 60 | (format stream "System ~S not found" 61 | (system-not-found-name condition)))) 62 | (:documentation "This condition is signaled by QUICKLOAD when a 63 | system given to load is not available via ASDF or a Quicklisp 64 | dist.")) 65 | 66 | (defun compute-load-strategy (name) 67 | (setf name (string-downcase name)) 68 | (let ((asdf-systems '()) 69 | (quicklisp-systems '())) 70 | (labels ((recurse (name) 71 | (let ((asdf-system (asdf:find-system name nil)) 72 | (quicklisp-system (find-system name))) 73 | (cond (asdf-system 74 | (push asdf-system asdf-systems)) 75 | (quicklisp-system 76 | (push quicklisp-system quicklisp-systems) 77 | (dolist (subname (required-systems quicklisp-system)) 78 | (recurse subname))) 79 | (t 80 | (cerror "Try again" 81 | 'system-not-found 82 | :name name) 83 | (recurse name)))))) 84 | (with-consistent-dists 85 | (recurse name))) 86 | (make-instance 'load-strategy 87 | :name name 88 | :asdf-systems (remove-duplicates asdf-systems) 89 | :quicklisp-systems (remove-duplicates quicklisp-systems)))) 90 | 91 | (defun show-load-strategy (strategy) 92 | (format t "~&To load ~S:~%" (name strategy)) 93 | (let ((asdf-systems (asdf-systems strategy)) 94 | (releases (quicklisp-releases strategy))) 95 | (when asdf-systems 96 | (format t " Load ~D ASDF system~:P:~%" (length asdf-systems)) 97 | (show-wrapped-list (mapcar 'asdf:component-name asdf-systems))) 98 | (when releases 99 | (format t " Install ~D Quicklisp release~:P:~%" (length releases)) 100 | (show-wrapped-list (mapcar 'name releases))))) 101 | 102 | (defvar *macroexpand-progress-in-progress* nil) 103 | 104 | (defun macroexpand-progress-fun (old-hook &key (char #\.) 105 | (chars-per-line 50) 106 | (forms-per-char 250)) 107 | (let ((output-so-far 0) 108 | (seen-so-far 0)) 109 | (labels ((finish-line () 110 | (when (plusp output-so-far) 111 | (dotimes (i (- chars-per-line output-so-far)) 112 | (write-char char)) 113 | (terpri) 114 | (setf output-so-far 0))) 115 | (show-string (string) 116 | (let* ((length (length string)) 117 | (new-output (+ length output-so-far))) 118 | (cond ((< chars-per-line new-output) 119 | (finish-line) 120 | (write-string string) 121 | (setf output-so-far length)) 122 | (t 123 | (write-string string) 124 | (setf output-so-far new-output)))) 125 | (finish-output)) 126 | (show-package (name) 127 | ;; Only show package markers when compiling. Showing 128 | ;; them when loading shows a bunch of ASDF system 129 | ;; package noise. 130 | (when *compile-file-pathname* 131 | (finish-line) 132 | (show-string (format nil "[package ~(~A~)]" name))))) 133 | (lambda (fun form env) 134 | (when (and (consp form) 135 | (eq (first form) 'cl:defpackage) 136 | (ignore-errors (string (second form)))) 137 | (show-package (second form))) 138 | (incf seen-so-far) 139 | (when (<= forms-per-char seen-so-far) 140 | (setf seen-so-far 0) 141 | (write-char char) 142 | (finish-output) 143 | (incf output-so-far) 144 | (when (<= chars-per-line output-so-far) 145 | (setf output-so-far 0) 146 | (terpri) 147 | (finish-output))) 148 | (funcall old-hook fun form env))))) 149 | 150 | (defun call-with-macroexpand-progress (fun) 151 | (let ((*macroexpand-hook* (if *macroexpand-progress-in-progress* 152 | *macroexpand-hook* 153 | (macroexpand-progress-fun *macroexpand-hook*))) 154 | (*macroexpand-progress-in-progress* t)) 155 | (funcall fun) 156 | (terpri))) 157 | 158 | (defun apply-load-strategy (strategy) 159 | (map nil 'ensure-installed (quicklisp-releases strategy)) 160 | (call-with-macroexpand-progress 161 | (lambda () 162 | (format t "~&; Loading ~S~%" (name strategy)) 163 | (asdf:load-system (name strategy) :verbose nil)))) 164 | 165 | (defun autoload-system-and-dependencies (name &key prompt) 166 | "Try to load the system named by NAME, automatically loading any 167 | Quicklisp-provided systems first, and catching ASDF missing 168 | dependencies too if possible." 169 | (setf name (string-downcase name)) 170 | (with-simple-restart (abort "Give up on ~S" name) 171 | (let ((tried-so-far (make-hash-table :test 'equalp))) 172 | (tagbody 173 | retry 174 | (handler-case 175 | (let ((strategy (compute-load-strategy name))) 176 | (show-load-strategy strategy) 177 | (when (or (not prompt) 178 | (press-enter-to-continue)) 179 | (apply-load-strategy strategy))) 180 | (asdf:missing-dependency-of-version (c) 181 | ;; Nothing Quicklisp can do to recover from this, so just 182 | ;; resignal 183 | (error c)) 184 | (asdf:missing-dependency (c) 185 | (let ((parent (asdf::missing-required-by c)) 186 | (missing (asdf::missing-requires c))) 187 | (typecase parent 188 | ((or null asdf:system) 189 | ;; NIL parent comes from :defsystem-depends-on failures 190 | (if (gethash missing tried-so-far) 191 | (error "Dependency looping -- already tried to load ~ 192 | ~A" missing) 193 | (setf (gethash missing tried-so-far) missing)) 194 | (autoload-system-and-dependencies missing 195 | :prompt prompt) 196 | (go retry)) 197 | (t 198 | ;; Error isn't from a system dependency, so there's 199 | ;; nothing to autoload 200 | (error c)))))))) 201 | name)) 202 | 203 | (defvar *initial-dist-url* 204 | "http://beta.quicklisp.org/dist/quicklisp.txt") 205 | 206 | (defun dists-initialized-p () 207 | (not (not (ignore-errors (truename (qmerge "dists/")))))) 208 | 209 | (defun quickstart-parameter (name &optional default) 210 | (let* ((package (find-package '#:quicklisp-quickstart)) 211 | (symbol (and package (find-symbol (string '#:*quickstart-parameters*) 212 | package))) 213 | (plist (and symbol (symbol-value symbol))) 214 | (parameter (and plist (getf plist name)))) 215 | (or parameter default))) 216 | 217 | (defun maybe-initial-setup () 218 | "Run the steps needed when Quicklisp setup is run for the first time 219 | after the quickstart installation." 220 | (let ((quickstart-proxy-url (quickstart-parameter :proxy-url)) 221 | (quickstart-initial-dist-url (quickstart-parameter :initial-dist-url))) 222 | (when (and quickstart-proxy-url (not *proxy-url*)) 223 | (setf *proxy-url* quickstart-proxy-url) 224 | (setf (config-value "proxy-url") quickstart-proxy-url)) 225 | (unless (dists-initialized-p) 226 | (let ((target (qmerge "dists/quicklisp/distinfo.txt")) 227 | (url (or quickstart-initial-dist-url 228 | *initial-dist-url*))) 229 | (ensure-directories-exist target) 230 | (install-dist url :prompt nil))))) 231 | 232 | (defun setup () 233 | (unless (member 'system-definition-searcher 234 | asdf:*system-definition-search-functions*) 235 | (setf asdf:*system-definition-search-functions* 236 | (append asdf:*system-definition-search-functions* 237 | (list 'local-projects-searcher 238 | 'system-definition-searcher)))) 239 | (let ((files (nconc (directory (qmerge "local-init/*.lisp")) 240 | (directory (qmerge "local-init/*.cl"))))) 241 | (with-simple-restart (abort "Stop loading local setup files") 242 | (dolist (file (sort files #'string< :key #'pathname-name)) 243 | (with-simple-restart (skip "Skip local setup file ~S" file) 244 | ;; Don't try to load Emacs lock files, other hidden files 245 | (unless (char= (char (pathname-name file) 0) 246 | #\.) 247 | (load file)))))) 248 | (maybe-initial-setup) 249 | (ensure-directories-exist (qmerge "local-projects/")) 250 | (pushnew :quicklisp *features*) 251 | t) 252 | -------------------------------------------------------------------------------- /quicklisp/utils.lisp: -------------------------------------------------------------------------------- 1 | ;;;; utils.lisp 2 | 3 | (in-package #:ql-util) 4 | 5 | (defun write-line-to-file (string file) 6 | (with-open-file (stream file 7 | :direction :output 8 | :if-exists :supersede) 9 | (write-line string stream))) 10 | 11 | (defvar *do-not-prompt* nil 12 | "When *DO-NOT-PROMPT* is true, PRESS-ENTER-TO-CONTINUE returns true 13 | without user interaction.") 14 | 15 | (defmacro without-prompting (&body body) 16 | "Evaluate BODY in an environment where PRESS-ENTER-TO-CONTINUE 17 | always returns true without prompting for the user to press enter." 18 | `(let ((*do-not-prompt* t)) 19 | ,@body)) 20 | 21 | (defun press-enter-to-continue () 22 | (when *do-not-prompt* 23 | (return-from press-enter-to-continue t)) 24 | (format *query-io* "~&Press Enter to continue.~%") 25 | (let ((result (read-line *query-io*))) 26 | (zerop (length result)))) 27 | 28 | (defun replace-file (from to) 29 | "Like RENAME-FILE, but deletes TO if it exists, first." 30 | (when (probe-file to) 31 | (delete-file to)) 32 | (rename-file from to)) 33 | 34 | (defun copy-file (from to &key (if-exists :rename-and-delete)) 35 | "Copy the file FROM to TO." 36 | (let* ((buffer-size 8192) 37 | (buffer (make-array buffer-size :element-type '(unsigned-byte 8)))) 38 | (with-open-file (from-stream from :element-type '(unsigned-byte 8)) 39 | (with-open-file (to-stream to :element-type '(unsigned-byte 8) 40 | :direction :output 41 | :if-exists if-exists) 42 | (let ((length (file-length from-stream))) 43 | (multiple-value-bind (full leftover) 44 | (floor length buffer-size) 45 | (dotimes (i full) 46 | (read-sequence buffer from-stream) 47 | (write-sequence buffer to-stream)) 48 | (read-sequence buffer from-stream) 49 | (write-sequence buffer to-stream :end leftover))))) 50 | (probe-file to))) 51 | 52 | (defun ensure-file-exists (pathname) 53 | (open pathname :direction :probe :if-does-not-exist :create)) 54 | 55 | (defun delete-file-if-exists (pathname) 56 | (when (probe-file pathname) 57 | (delete-file pathname))) 58 | 59 | (defun split-spaces (line) 60 | (let ((words '()) 61 | (mark 0) 62 | (pos 0)) 63 | (labels ((finish () 64 | (setf pos (length line)) 65 | (save) 66 | (return-from split-spaces (nreverse words))) 67 | (save () 68 | (when (< mark pos) 69 | (push (subseq line mark pos) words))) 70 | (mark () 71 | (setf mark pos)) 72 | (in-word (char) 73 | (case char 74 | (#\Space 75 | (save) 76 | #'in-space) 77 | (t 78 | #'in-word))) 79 | (in-space (char) 80 | (case char 81 | (#\Space 82 | #'in-space) 83 | (t 84 | (mark) 85 | #'in-word)))) 86 | (let ((state #'in-word)) 87 | (dotimes (i (length line) (finish)) 88 | (setf pos i) 89 | (setf state (funcall state (char line i)))))))) 90 | 91 | (defun first-line (file) 92 | (with-open-file (stream file) 93 | (values (read-line stream)))) 94 | 95 | (defun (setf first-line) (line file) 96 | (with-open-file (stream file :direction :output 97 | :if-exists :rename-and-delete) 98 | (write-line line stream))) 99 | 100 | (defun file-size (file) 101 | (with-open-file (stream file :element-type '(unsigned-byte 8)) 102 | (file-length stream))) 103 | 104 | (defun safely-read (stream) 105 | "Read one form from STREAM with *READ-EVAL* bound to NIL." 106 | (let ((*read-eval* nil)) 107 | (read stream))) 108 | 109 | (defun safely-read-file (file) 110 | "Read the first form from FILE with SAFELY-READ." 111 | (with-open-file (stream file) 112 | (safely-read stream))) 113 | 114 | (defun make-versions-url (url) 115 | "Given an URL that looks like http://foo/bar.ext, return 116 | http://foo/bar-versions.txt." 117 | (let ((suffix-pos (position #\. url :from-end t))) 118 | (unless suffix-pos 119 | (error "Can't make a versions URL from ~A" url)) 120 | (let ((extension (subseq url suffix-pos))) 121 | (concatenate 'string 122 | (subseq url 0 suffix-pos) 123 | "-versions" 124 | extension)))) 125 | 126 | (defun call-with-temporary-file (fun template-pathname) 127 | (assert (null (pathname-directory template-pathname))) 128 | (let* ((relative-file (merge-pathnames template-pathname 129 | #p"tmp/")) 130 | (absolute-file (ql-setup:qmerge relative-file)) 131 | (randomized-file (make-pathname :name (format nil "~A-~36,5,'0R" 132 | (pathname-name template-pathname) 133 | (random #xFFFFFF)) 134 | :defaults absolute-file))) 135 | (unwind-protect 136 | (funcall fun randomized-file) 137 | (delete-file-if-exists randomized-file)))) 138 | 139 | ;;; TODO: Use this where (qmerge "tmp/...") is used, when possible 140 | (defmacro with-temporary-file ((var template) &body body) 141 | "Evaluate BODY with VAR bound to a temporary pathname created by 142 | adding random data to the pathname-name of TEMPLATE, which should be a 143 | pathname without a directory component. After evaluation, the 144 | temporary pathname is deleted if it exists." 145 | `(call-with-temporary-file (lambda (,var) ,@body) ,template)) 146 | -------------------------------------------------------------------------------- /quicklisp/version.txt: -------------------------------------------------------------------------------- 1 | 2021-02-13 2 | -------------------------------------------------------------------------------- /setup.lisp: -------------------------------------------------------------------------------- 1 | (defpackage #:ql-setup 2 | (:use #:cl) 3 | (:export #:*quicklisp-home* 4 | #:qmerge 5 | #:qenough)) 6 | 7 | (in-package #:ql-setup) 8 | 9 | (unless *load-truename* 10 | (error "This file must be LOADed to set up quicklisp.")) 11 | 12 | (defvar *quicklisp-home* 13 | (make-pathname :name nil :type nil 14 | :defaults *load-truename*)) 15 | 16 | (defun qmerge (pathname) 17 | "Return PATHNAME merged with the base Quicklisp directory." 18 | (merge-pathnames pathname *quicklisp-home*)) 19 | 20 | (defun qenough (pathname) 21 | (enough-namestring pathname *quicklisp-home*)) 22 | 23 | ;;; ASDF is a hard requirement of quicklisp. Make sure it's either 24 | ;;; already loaded or load it from quicklisp's bundled version. 25 | 26 | (defvar *required-asdf-version* "3.0") 27 | 28 | ;;; Put ASDF's fasls in a separate directory 29 | 30 | (defun implementation-signature () 31 | "Return a string suitable for discriminating different 32 | implementations, or similar implementations with possibly-incompatible 33 | FASLs." 34 | ;; XXX Will this have problems with stuff like threads vs 35 | ;; non-threads fasls? 36 | (let ((*print-pretty* nil)) 37 | (format nil "lisp-implementation-type: ~A~%~ 38 | lisp-implementation-version: ~A~%~ 39 | machine-type: ~A~%~ 40 | machine-version: ~A~%" 41 | (lisp-implementation-type) 42 | (lisp-implementation-version) 43 | (machine-type) 44 | (machine-version)))) 45 | 46 | (defun dumb-string-hash (string) 47 | "Produce a six-character hash of STRING." 48 | (let ((hash #xD13CCD13)) 49 | (loop for char across string 50 | for value = (char-code char) 51 | do 52 | (setf hash (logand #xFFFFFFFF 53 | (logxor (ash hash 5) 54 | (ash hash -27) 55 | value)))) 56 | (subseq (format nil "~(~36,6,'0R~)" (mod hash 88888901)) 57 | 0 6))) 58 | 59 | (defun asdf-fasl-pathname () 60 | "Return a pathname suitable for storing the ASDF FASL, separated 61 | from ASDF FASLs from incompatible implementations. Also, save a file 62 | in the directory with the implementation signature, if it doesn't 63 | already exist." 64 | (let* ((implementation-signature (implementation-signature)) 65 | (original-fasl (compile-file-pathname (qmerge "asdf.lisp"))) 66 | (fasl 67 | (qmerge (make-pathname 68 | :defaults original-fasl 69 | :directory 70 | (list :relative 71 | "cache" 72 | "asdf-fasls" 73 | (dumb-string-hash implementation-signature))))) 74 | (signature-file (merge-pathnames "signature.txt" fasl))) 75 | (ensure-directories-exist fasl) 76 | (unless (probe-file signature-file) 77 | (with-open-file (stream signature-file :direction :output) 78 | (write-string implementation-signature stream))) 79 | fasl)) 80 | 81 | (defun ensure-asdf-loaded () 82 | "Try several methods to make sure that a sufficiently-new ASDF is 83 | loaded: first try (require \"asdf\"), then loading the ASDF FASL, then 84 | compiling asdf.lisp to a FASL and then loading it." 85 | (let ((source (qmerge "asdf.lisp"))) 86 | (labels ((asdf-symbol (name) 87 | (let ((asdf-package (find-package '#:asdf))) 88 | (when asdf-package 89 | (find-symbol (string name) asdf-package)))) 90 | (version-satisfies (version) 91 | (let ((vs-fun (asdf-symbol '#:version-satisfies)) 92 | (vfun (asdf-symbol '#:asdf-version))) 93 | (when (and vs-fun vfun 94 | (fboundp vs-fun) 95 | (fboundp vfun)) 96 | (funcall vs-fun (funcall vfun) version))))) 97 | (block nil 98 | (macrolet ((try (&body asdf-loading-forms) 99 | `(progn 100 | (handler-bind ((warning #'muffle-warning)) 101 | (ignore-errors 102 | ,@asdf-loading-forms)) 103 | (when (version-satisfies *required-asdf-version*) 104 | (return t))))) 105 | (try) 106 | (try (require "asdf")) 107 | (let ((fasl (asdf-fasl-pathname))) 108 | (try (load fasl :verbose nil)) 109 | (try (load (compile-file source :verbose nil :output-file fasl)))) 110 | (error "Could not load ASDF ~S or newer" *required-asdf-version*)))))) 111 | 112 | (ensure-asdf-loaded) 113 | 114 | ;;; 115 | ;;; Quicklisp sometimes must upgrade ASDF. Ugrading ASDF will blow 116 | ;;; away existing ASDF methods, so e.g. FASL recompilation :around 117 | ;;; methods would be lost. This config file will make it possible to 118 | ;;; ensure ASDF can be configured before loading Quicklisp itself via 119 | ;;; ASDF. Thanks to Nikodemus Siivola for pointing out this issue. 120 | ;;; 121 | 122 | (let ((asdf-init (probe-file (qmerge "asdf-config/init.lisp")))) 123 | (when asdf-init 124 | (with-simple-restart (skip "Skip loading ~S" asdf-init) 125 | (load asdf-init :verbose nil :print nil)))) 126 | 127 | (push (qmerge "quicklisp/") asdf:*central-registry*) 128 | 129 | (let ((*compile-print* nil) 130 | (*compile-verbose* nil) 131 | (*load-verbose* nil) 132 | (*load-print* nil)) 133 | (asdf:oos 'asdf:load-op "quicklisp" :verbose nil)) 134 | 135 | (quicklisp:setup) 136 | --------------------------------------------------------------------------------