pax_global_header00006660000000000000000000000064140121015030014475gustar00rootroot0000000000000052 comment=8b63e00b3a2b3f96e24c113d7601dd03a128ce94 quicklisp/000077500000000000000000000000001401210150300130455ustar00rootroot00000000000000quicklisp/bundle-template.lisp000066400000000000000000000155021401210150300170230ustar00rootroot00000000000000(cl:in-package #:cl-user) (eval-when (:compile-toplevel :load-toplevel :execute) (require "asdf") (unless (find-package '#:asdf) (error "ASDF could not be required"))) (let ((indicator '#:ql-bundle-v1) (searcher-name '#:ql-bundle-searcher) (base (make-pathname :name nil :type nil :defaults #. (or *compile-file-truename* *load-truename*)))) (labels ((file-lines (file) (with-open-file (stream file) (loop for line = (read-line stream nil) while line collect line))) (relative (pathname) (merge-pathnames pathname base)) (pathname-timestamp (pathname) #+clisp (nth-value 2 (ext:probe-pathname pathname)) #-clisp (file-write-date pathname)) (system-table (table pathnames) (dolist (pathname pathnames table) (setf (gethash (pathname-name pathname) table) (relative pathname)))) (initialize-bundled-systems-table (table data-source) (system-table table (mapcar (lambda (line) (merge-pathnames line data-source)) (file-lines data-source)))) (local-projects-system-pathnames (data-source) (let ((files (directory (merge-pathnames "**/*.asd" data-source)))) (stable-sort (sort files #'string< :key #'namestring) #'< :key (lambda (file) (length (namestring file)))))) (initialize-local-projects-table (table data-source) (system-table table (local-projects-system-pathnames data-source))) (make-table (&key data-source init-function) (let ((table (make-hash-table :test 'equalp))) (setf (gethash "/data-source" table) data-source (gethash "/timestamp" table) (pathname-timestamp data-source) (gethash "/init" table) init-function) table)) (tcall (table key &rest args) (let ((fun (gethash key table))) (unless (and fun (functionp fun)) (error "Unknown function key ~S" key)) (apply fun args))) (created-timestamp (table) (gethash "/timestamp" table)) (data-source-timestamp (table) (pathname-timestamp (data-source table))) (data-source (table) (gethash "/data-source" table)) (stalep (table) ;; FIXME: Handle newly missing data sources? (< (created-timestamp table) (data-source-timestamp table))) (meta-key-p (key) (and (stringp key) (< 0 (length key)) (char= (char key 0) #\/))) (clear (table) ;; Don't clear "/foo" keys (maphash (lambda (key value) (declare (ignore value)) (unless (meta-key-p key) (remhash key table))) table)) (initialize (table) (tcall table "/init" table (data-source table)) (setf (gethash "/timestamp" table) (pathname-timestamp (data-source table))) table) (update (table) (clear table) (initialize table)) (lookup (system-name table) (when (stalep table) (update table)) (values (gethash system-name table))) (search-function (system-name) (let ((tables (get searcher-name indicator))) (dolist (table tables) (let* ((result (lookup system-name table)) (probed (and result (probe-file result)))) (when probed (return probed)))))) (make-bundled-systems-table () (initialize (make-table :data-source (relative "system-index.txt") :init-function #'initialize-bundled-systems-table))) (make-bundled-local-projects-systems-table () (let ((data-source (relative "bundled-local-projects/system-index.txt"))) (when (probe-file data-source) (initialize (make-table :data-source data-source :init-function #'initialize-bundled-systems-table))))) (make-local-projects-table () (initialize (make-table :data-source (relative "local-projects/") :init-function #'initialize-local-projects-table))) (=matching-data-sources (tables) (let ((data-sources (mapcar #'data-source tables))) (lambda (table) (member (data-source table) data-sources :test #'equalp)))) (check-for-existing-searcher (searchers) (block done (dolist (searcher searchers) (when (symbolp searcher) (let ((plist (symbol-plist searcher))) (loop for key in plist by #'cddr when (and (symbolp key) (string= key indicator)) do (setf indicator key) (setf searcher-name searcher) (return-from done t))))))) (clear-asdf (table) (maphash (lambda (system-name pathname) (declare (ignore pathname)) (asdf:clear-system system-name)) table))) (let ((existing (check-for-existing-searcher asdf:*system-definition-search-functions*))) (let* ((local (make-local-projects-table)) (bundled-local-projects (make-bundled-local-projects-systems-table)) (bundled (make-bundled-systems-table)) (new-tables (remove nil (list local bundled-local-projects bundled))) (existing-tables (get searcher-name indicator)) (filter (=matching-data-sources new-tables))) (setf (get searcher-name indicator) (append new-tables (delete-if filter existing-tables))) (map nil #'clear-asdf new-tables)) (unless existing (setf (symbol-function searcher-name) #'search-function) (push searcher-name asdf:*system-definition-search-functions*))) t)) quicklisp/bundle.lisp000066400000000000000000000333661401210150300152220ustar00rootroot00000000000000;;;; bundle.lisp (in-package #:ql-bundle) ;;; Bundling is taking a set of Quicklisp-provided systems and ;;; creating a directory structure and metadata in which those systems ;;; can be loaded without involving Quicklisp. ;;; ;;; This works for systems provided directly Quicklisp, or systems in ;;; the Quicklisp local-projects directories (if ;;; :include-local-projects is specified). (defgeneric find-system (system bundle)) (defgeneric add-system (system bundle)) (defgeneric ensure-system (system bundle)) (defgeneric find-release (relase bundle)) (defgeneric add-release (release bundle)) (defgeneric ensure-release (release bundle)) (defgeneric write-loader-script (bundle stream)) (defgeneric write-system-index (bundle stream)) (defgeneric unpack-release (release target)) (defgeneric unpack-releases (bundle target)) (defgeneric write-bundle (bundle target)) (defvar *ignored-systems* (list "asdf") "Systems that might appear in depends-on lists in Quicklisp, but which can't be bundled.") (defvar *bundle-progress-output* (make-synonym-stream '*trace-output*) "Informative output related to creating the bundle is sent to this stream.") ;;; Implementation ;;; Conditions (define-condition bundle-error (error) ()) (define-condition object-not-found (bundle-error) ((name :initarg :name :reader object-not-found-name) (type :initarg :type :reader object-not-found-type)) (:report (lambda (condition stream) (format stream "~A ~S not found" (object-not-found-type condition) (object-not-found-name condition)))) (:default-initargs :type "Object")) (define-condition system-not-found (object-not-found) ((name :reader system-not-found-system)) (:default-initargs :type "System")) (define-condition release-not-found (object-not-found) () (:default-initargs :type "Release")) (define-condition bundle-directory-exists (bundle-error) ((directory :initarg :directory :reader bundle-directory-exists-directory)) (:report (lambda (condition stream) (format stream "Bundle directory ~A already exists" (bundle-directory-exists-directory condition))))) (defun iso8601-time-stamp (&optional (time (get-universal-time))) (multiple-value-bind (second minute hour day month year) (decode-universal-time time 0) (format nil "~4,'0D-~2,'0D-~2,'0DT~ ~2,'0D:~2,'0D:~2,'0DZ" year month day hour minute second))) (defclass bundle () ((requested-systems :initarg :requested-systems :reader requested-systems :documentation "Names of the systems requested directly for bundling.") (creation-time :initarg :creation-time :reader creation-time) (release-table :initarg :release-table :reader release-table) (system-table :initarg :system-table :reader system-table)) (:default-initargs :requested-systems nil :creation-time (iso8601-time-stamp) :release-table (make-hash-table :test 'equalp) :system-table (make-hash-table :test 'equalp))) (defmethod print-object ((bundle bundle) stream) (print-unreadable-object (bundle stream :type t) (format stream "~D release~:P, ~D system~:P" (hash-table-count (release-table bundle)) (hash-table-count (system-table bundle))))) (defmethod provided-releases ((bundle bundle)) (let ((releases '())) (maphash (lambda (name release) (declare (ignore name)) (push release releases)) (release-table bundle)) (sort releases 'string< :key 'name))) (defmethod provided-systems ((bundle bundle)) (sort (mapcan #'provided-systems (provided-releases bundle)) 'string< :key 'name)) (defmethod find-system (name (bundle bundle)) (values (gethash name (system-table bundle)))) (defmethod add-system (name (bundle bundle)) (let ((system (ql-dist:find-system name))) (unless system (error 'system-not-found :name name)) (ensure-release (name (release system)) bundle) system)) (defmethod ensure-system (name (bundle bundle)) (or (find-system name bundle) (add-system name bundle))) (defmethod find-release (name (bundle bundle)) (values (gethash name (release-table bundle)))) (defmethod add-release (name (bundle bundle)) (let ((release (ql-dist:find-release name))) (unless release (error 'release-not-found :name name)) (setf (gethash (name release) (release-table bundle)) release) (let ((system-table (system-table bundle))) (dolist (system (provided-systems release)) (setf (gethash (name system) system-table) system))) release)) (defmethod ensure-release (name (bundle bundle)) (or (find-release name bundle) (add-release name bundle))) (defun add-systems-recursively (names bundle) (with-consistent-dists (labels ((add-one (name) (unless (member name *ignored-systems* :test 'equalp) (let ((system (restart-case (ensure-system name bundle) (omit () :report "Ignore this system and omit it from the bundle.")))) (when system (dolist (required-system-name (required-systems system)) (add-one required-system-name))))))) (map nil #'add-one names))) bundle) (defmethod unpack-release (release target) (let ((*default-pathname-defaults* (truename (ensure-directories-exist target))) (archive (ensure-local-archive-file release)) (temp-tar (ensure-directories-exist (ql-setup:qmerge "tmp/bundle.tar")))) (ql-gunzipper:gunzip archive temp-tar) (ql-minitar:unpack-tarball temp-tar :directory "software/") (delete-file temp-tar) release)) (defmethod unpack-releases ((bundle bundle) target) (dolist (release (provided-releases bundle)) (unpack-release release target)) bundle) (defmethod write-system-index ((bundle bundle) stream) (dolist (release (provided-releases bundle)) ;; Working with strings, here, intentionally not with pathnames (let ((prefix (concatenate 'string "software/" (prefix release)))) (dolist (system-file (system-files release)) (format stream "~A/~A~%" prefix system-file))))) (defmethod write-loader-script ((bundle bundle) stream) (let ((template-lines (load-time-value (with-open-file (stream #. (merge-pathnames "bundle-template" (or *compile-file-truename* *load-truename*))) (loop for line = (read-line stream nil) while line collect line))))) (dolist (line template-lines) (write-line line stream)))) (defun coerce-to-directory (pathname) ;; Cribbed from quicklisp-bootstrap/quicklisp.lisp (let ((name (file-namestring pathname))) (if (or (null name) (equal name "")) pathname (make-pathname :defaults pathname :name nil :type nil :directory (append (pathname-directory pathname) (list name)))))) (defun bundle-metadata-plist (bundle) (list :creation-time (creation-time bundle) :requested-systems (requested-systems bundle) :lisp-info (list :machine-instance (machine-instance) :machine-type (machine-type) :machine-version (machine-version) :lisp-implementation-type (lisp-implementation-type) :lisp-implementation-version (lisp-implementation-version)) :quicklisp-info (list :home (namestring ql:*quicklisp-home*) :local-project-directories (mapcar 'namestring ql:*local-project-directories*) :dists (loop for dist in (enabled-dists) collect (list :name (name dist) :dist-url (canonical-distinfo-url dist) :version (version dist)))))) (defmethod write-bundle ((bundle bundle) target) (unpack-releases bundle target) (let ((index-file (merge-pathnames "system-index.txt" target)) (loader-file (merge-pathnames "bundle.lisp" target)) (local-projects (merge-pathnames "local-projects/" target)) (metadata-file (merge-pathnames "bundle-info.sexp" target))) (ensure-directories-exist local-projects) (with-open-file (stream index-file :direction :output :if-exists :supersede) (write-system-index bundle stream)) (with-open-file (stream loader-file :direction :output :if-exists :supersede) (write-loader-script bundle stream)) (with-open-file (stream metadata-file :direction :output :if-exists :supersede) (with-standard-io-syntax (let ((*print-pretty* t)) (prin1 (bundle-metadata-plist bundle) stream) (terpri stream)))) (probe-file loader-file))) (defun copy-file (from-file to-file) (with-open-file (from-stream from-file :element-type '(unsigned-byte 8) :if-does-not-exist nil) (when from-stream (let ((buffer (make-array 10000 :element-type '(unsigned-byte 8)))) (with-open-file (to-stream to-file :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (loop (let ((end-index (read-sequence buffer from-stream))) (when (zerop end-index) (return to-file)) (write-sequence buffer to-stream :end end-index)))))))) (defun copy-directory-tree (from-directory to-directory) ;; Use the truename here to ensure that relative pathnames match up ;; properly. For example, on SBCL, "~/foo/bar/" entries are not ;; relative to "/home/baz/foo/bar/" entries. (setf from-directory (truename from-directory)) (map-directory-tree from-directory (lambda (from-pathname) (when (probe-file from-pathname) (let* ((relative (enough-namestring from-pathname from-directory)) (relative-directory (pathname-directory relative)) (to-pathname (merge-pathnames relative to-directory))) (unless (or (null relative-directory) (eql (first relative-directory) :relative)) (error "Expected relative pathname to copy from ~A ~ - bad symlink? - ~S" from-pathname relative)) (ensure-directories-exist to-pathname) (copy-file from-pathname to-pathname)))))) (defun copy-local-projects-directories (local-projects-directories to-directory) "Copy the local-projects directories to TO-DIRECTORY. Each one gets a distinct subdirectory." (loop for prefix from 0 for prefix-directory = (make-pathname :directory (list :relative (format nil "~4,'0X" prefix))) for from-directory in local-projects-directories for real-to-directory = (merge-pathnames prefix-directory to-directory) do (format *bundle-progress-output* "~&; Copying ~A to bundle..." from-directory ) (force-output *bundle-progress-output*) (ensure-directories-exist real-to-directory) (copy-directory-tree from-directory real-to-directory) (format *bundle-progress-output* "done.~%") (force-output *bundle-progress-output*))) (defun ql:bundle-systems (system-names &key include-local-projects to (overwrite t)) "In the directory TO, construct a self-contained bundle of libraries based on SYSTEM-NAMES. For each system named, and its recursive required systems, unpack its release archive in TO/software/, and write a system index, compatible with the output of QL:WRITE-ASDF-MANIFEST-FILE, to TO/system-index.txt. Write a loader script to TO/bundle.lisp that, when loaded via CL:LOAD, configures ASDF to load systems from the bundle before any other system. SYSTEM-NAMES must name systems provided directly by Quicklisp. If INCLUDE-LOCAL-PROJECTS is true, each directory in QL:*LOCAL-PROJECT-DIRECTORIES* is copied into the bundle and loaded before any of the other bundled systems." (unless to (error "TO argument must be provided")) (let* ((bundle (make-instance 'bundle :requested-systems system-names)) (to (coerce-to-directory to)) (software (merge-pathnames "software/" to))) (when (and (probe-directory to) (not overwrite)) (cerror "Overwrite it" 'bundle-directory-exists :directory to)) (when (probe-directory software) (delete-directory-tree software)) (add-systems-recursively system-names bundle) (let ((bundled-local-projects (merge-pathnames "bundled-local-projects/" to))) (when include-local-projects (when (probe-directory bundled-local-projects) (delete-directory-tree bundled-local-projects)) (copy-local-projects-directories ql:*local-project-directories* bundled-local-projects) (ensure-directories-exist bundled-local-projects) (ql::make-system-index bundled-local-projects))) (values (write-bundle bundle to) bundle))) quicklisp/cdb.lisp000066400000000000000000000323541401210150300144750ustar00rootroot00000000000000;;;; cdb.lisp (in-package #:ql-cdb) (defconstant +initial-hash-value+ 5381) (defun cdb-hash (octets) "http://cr.yp.to/cdb/cdb.txt" (declare (type (simple-array (unsigned-byte 8) (*)) octets) (optimize speed)) (let ((h +initial-hash-value+)) (declare (type (unsigned-byte 32) h)) (dotimes (i (length octets) h) (let ((c (aref octets i))) (setf h (logand #xFFFFFFFF (+ h (ash h 5)))) (setf h (logxor h c)))))) (defun make-growable-vector (&key (size 10) (element-type t)) (make-array size :fill-pointer 0 :adjustable t :element-type element-type)) (defun make-octet-vector (size) (make-array size :element-type '(unsigned-byte 8))) (defun encode-string (string) "Do a bare-bones ASCII encoding of STRING." (map-into (make-octet-vector (length string)) 'char-code string)) (defun decode-octets (octets) "Do a bare-bones ASCII decoding of OCTETS." (map-into (make-string (length octets)) 'code-char octets)) (defun read-cdb-u32 (stream) (logand #xFFFFFFFF (logior (ash (read-byte stream) 0) (ash (read-byte stream) 8) (ash (read-byte stream) 16) (ash (read-byte stream) 24)))) (defun lookup-record-at (position key stream) (file-position stream position) (let ((key-size (read-cdb-u32 stream)) (value-size (read-cdb-u32 stream))) (when (= key-size (length key)) (let ((test-key (make-octet-vector key-size))) (when (/= key-size (read-sequence test-key stream)) (error "Could not read record key of size ~D from cdb stream" key-size)) (unless (mismatch test-key key :test #'=) (let ((value (make-octet-vector value-size))) (if (= value-size (read-sequence value stream)) value (error "Could not read record value of size ~D from cdb stream" value-size)))))))) (defun table-slot-lookup (key hash table-position initial-slot slot-count stream) (let ((slot initial-slot)) (loop (file-position stream (+ table-position (* slot 8))) (let ((test-hash (read-cdb-u32 stream)) (record-position (read-cdb-u32 stream))) (when (zerop record-position) (return)) (when (= hash test-hash) (let ((value (lookup-record-at record-position key stream))) (when value (return value))))) (setf slot (mod (1+ slot) slot-count))))) (defun stream-lookup (key stream) (let* ((hash (cdb-hash key)) (pointer-index (logand #xFF hash))) (file-position stream (* pointer-index 8)) (let ((table-position (read-cdb-u32 stream)) (slot-count (read-cdb-u32 stream))) (when (plusp slot-count) (let ((initial-slot (mod (ash hash -8) slot-count))) (table-slot-lookup key hash table-position initial-slot slot-count stream)))))) (defun %lookup (key cdb) "Return the value for KEY in CDB, or NIL if no matching key is found. CDB should be a pathname or an open octet stream. The key should be a vector of octets. The returned value will be a vector of octets." (if (streamp cdb) (stream-lookup key cdb) (with-open-file (stream cdb :element-type '(unsigned-byte 8)) (stream-lookup key stream)))) (defun lookup (key cdb) "Return the value for KEY in CDB, or NIL if no matching key is found. CDB should be a pathname or an open octet stream. The key should be an ASCII-encodable string. The returned value will be a string." (let ((value (%lookup (encode-string key) cdb))) (when value (decode-octets value)))) (defun stream-map-cdb (function stream) (labels ((map-one-slot (i) (file-position stream (* i 8)) (let ((table-position (read-cdb-u32 stream)) (slot-count (read-cdb-u32 stream))) (when (plusp slot-count) (map-one-table table-position slot-count)))) (map-one-table (position count) (dotimes (i count) (file-position stream (+ position (* i 8))) (let ((hash (read-cdb-u32 stream)) (position (read-cdb-u32 stream))) (declare (ignore hash)) (when (plusp position) (map-record position))))) (map-record (position) (file-position stream position) (let* ((key-size (read-cdb-u32 stream)) (value-size (read-cdb-u32 stream)) (key (make-octet-vector key-size)) (value (make-octet-vector value-size))) (read-sequence key stream) (read-sequence value stream) (funcall function key value)))) (dotimes (i 256) (map-one-slot i)))) (defun %map-cdb (function cdb) "Call FUNCTION once with each key and value in CDB." (if (streamp cdb) (stream-map-cdb function cdb) (with-open-file (stream cdb :element-type '(unsigned-byte 8)) (stream-map-cdb function stream)))) (defun map-cdb (function cdb) (%map-cdb (lambda (key value) (funcall function (decode-octets key) (decode-octets value))) cdb)) ;;; Writing CDB files (defun write-cdb-u32 (u32 stream) "Write an (unsigned-byte 32) value to STREAM in little-endian order." (write-byte (ldb (byte 8 0) u32) stream) (write-byte (ldb (byte 8 8) u32) stream) (write-byte (ldb (byte 8 16) u32) stream) (write-byte (ldb (byte 8 24) u32) stream)) (defclass record-pointer () ((hash-value :initarg :hash-value :accessor hash-value :documentation "The hash value of the record key.") (record-position :initarg :record-position :accessor record-position :documentation "The file position at which the record is stored.")) (:default-initargs :hash-value 0 :record-position 0) (:documentation "Every key/value record written to a CDB has a corresponding record pointer, which tracks the key's hash value and the record's position in the data file. When all records have been written to the file, these record pointers are organized into hash tables at the end of the cdb file.")) (defmethod print-object ((record-pointer record-pointer) stream) (print-unreadable-object (record-pointer stream :type t) (format stream "~8,'0X@~:D" (hash-value record-pointer) (record-position record-pointer)))) (defvar *empty-record-pointer* (make-instance 'record-pointer)) (defclass hash-table-bucket () ((table-position :initarg :table-position :accessor table-position :documentation "The file position at which this table is (eventually) slotted.") (entries :initarg :entries :accessor entries :documentation "A vector of record-pointers.")) (:default-initargs :table-position 0 :entries (make-growable-vector)) (:documentation "During construction of the CDB, record pointers are accumulated into one of 256 hash table buckets, depending on the low 8 bits of the hash value of the key. At the end of record writing, these buckets are used to write out hash table vectors at the end of the file, and write pointers to the hash table vectors at the start of the file.")) (defgeneric entry-count (object) (:method ((object hash-table-bucket)) (length (entries object)))) (defgeneric slot-count (object) (:method ((object hash-table-bucket)) (* (entry-count object) 2))) (defun bucket-hash-vector (bucket) "Create a hash vector for a bucket. A hash vector has 2x the entries of the bucket, and is initialized to an empty record pointer. The high 24 bits of the hash value of a record pointer, mod the size of the vector, is used as a starting slot, and the vector is walked (wrapping at the end) to find the first free slot for positioning each record pointer entry." (let* ((size (slot-count bucket)) (vector (make-array size :initial-element nil))) (flet ((slot (record) (let ((index (mod (ash (hash-value record) -8) size))) (loop (unless (aref vector index) (return (setf (aref vector index) record))) (setf index (mod (1+ index) size)))))) (map nil #'slot (entries bucket))) (nsubstitute *empty-record-pointer* nil vector))) (defmethod print-object ((bucket hash-table-bucket) stream) (print-unreadable-object (bucket stream :type t) (format stream "~D entr~:@P" (entry-count bucket)))) (defclass cdb-writer () ((buckets :initarg :buckets :accessor buckets) (end-of-records-position :initarg :end-of-records-position :accessor end-of-records-position) (output :initarg :output :accessor output)) (:default-initargs :end-of-records-position 2048 :buckets (map-into (make-array 256) (lambda () (make-instance 'hash-table-bucket))))) (defun add-record (key value cdb-writer) "Add KEY and VALUE to a cdb file. KEY and VALUE should both be (unsigned-byte 8) vectors." (let* ((output (output cdb-writer)) (hash-value (cdb-hash key)) (bucket-index (logand #xFF hash-value)) (bucket (aref (buckets cdb-writer) bucket-index)) (record-position (file-position output)) (record-pointer (make-instance 'record-pointer :record-position record-position :hash-value hash-value))) (vector-push-extend record-pointer (entries bucket)) (write-cdb-u32 (length key) output) (write-cdb-u32 (length value) output) (write-sequence key output) (write-sequence value output) (force-output output) (incf (end-of-records-position cdb-writer) (+ 8 (length key) (length value))))) (defun write-bucket-hash-table (bucket stream) "Write BUCKET's hash table vector to STREAM." (map nil (lambda (pointer) (write-cdb-u32 (hash-value pointer) stream) (write-cdb-u32 (record-position pointer) stream)) (bucket-hash-vector bucket))) (defun write-hash-tables (cdb-writer) "Write the traililng hash tables to the end of the cdb file. Initializes the position of the buckets in the process." (let ((stream (output cdb-writer))) (map nil (lambda (bucket) (setf (table-position bucket) (file-position stream)) (write-bucket-hash-table bucket stream)) (buckets cdb-writer)))) (defun write-pointers (cdb-writer) "Write the leading hash table pointers to the beginning of the cdb file. Must be called after WRITE-HASH-TABLES, or the positions won't be available." (let ((stream (output cdb-writer))) (file-position stream :start) (map nil (lambda (bucket) (let ((position (table-position bucket)) (count (slot-count bucket))) (when (zerop position) (error "Table positions not initialized correctly")) (write-cdb-u32 position stream) (write-cdb-u32 count stream))) (buckets cdb-writer)))) (defun finish-cdb-writer (cdb-writer) "Write the trailing hash tables and leading table pointers to the cdb file." (write-hash-tables cdb-writer) (write-pointers cdb-writer) (force-output (output cdb-writer))) (defvar *pointer-padding* (make-array 2048 :element-type '( unsigned-byte 8))) (defun call-with-output-to-cdb (cdb-pathname temp-pathname fun) "Call FUN with one argument, a CDB-WRITER instance to which records can be added with ADD-RECORD." (with-open-file (stream temp-pathname :direction :output :element-type '(unsigned-byte 8) :if-exists :supersede) (let ((cdb (make-instance 'cdb-writer :output stream))) (write-sequence *pointer-padding* stream) (funcall fun cdb) (finish-cdb-writer cdb))) (values (rename-file temp-pathname cdb-pathname))) (defmacro with-output-to-cdb ((cdb file temp-file) &body body) "Evaluate BODY with CDB bound to a CDB-WRITER object. The CDB in progress is written to TEMP-FILE, and then when the CDB is successfully written, TEMP-FILE is renamed to FILE. For atomic operation, FILE and TEMP-FILE must be on the same filesystem." `(call-with-output-to-cdb ,file ,temp-file (lambda (,cdb) ,@body))) ;;; Index file (systems.txt, releases.txt) conversion (defun convert-index-file (index-file &key (cdb-file (make-pathname :type "cdb" :defaults index-file)) (index 0)) (with-open-file (stream index-file) (let ((header (read-line stream))) (unless (and (plusp (length header)) (char= (char header 0) #\#)) (error "Bad header line in ~A -- ~S" index-file header))) (with-output-to-cdb (cdb cdb-file (make-pathname :type "cdb-tmp" :defaults cdb-file)) (loop for line = (read-line stream nil) for words = (and line (ql-util:split-spaces line)) while line do (add-record (encode-string (elt words index)) (encode-string line) cdb))))) quicklisp/client-info.lisp000066400000000000000000000210201401210150300161400ustar00rootroot00000000000000;;;; client-info.lisp (in-package #:quicklisp-client) (defparameter *client-base-url* "http://beta.quicklisp.org/") (defgeneric info-equal (info1 info2) (:documentation "Return TRUE if INFO1 and INFO2 are 'equal' in some important sense.")) ;;; Information for checking the validity of files fetched for ;;; installing/updating the client code. (defclass client-file-info () ((plist-key :initarg :plist-key :reader plist-key) (file-url :initarg :url :reader file-url) (name :reader name :initarg :name) (size :initarg :size :reader size) (md5 :reader md5 :initarg :md5) (sha256 :reader sha256 :initarg :sha256) (plist :reader plist :initarg :plist))) (defmethod print-object ((info client-file-info) stream) (print-unreadable-object (info stream :type t) (format stream "~S ~D ~S" (name info) (size info) (md5 info)))) (defmethod info-equal ((info1 client-file-info) (info2 client-file-info)) (and (eql (size info1) (size info2)) (equal (name info1) (name info2)) (equal (md5 info1) (md5 info2)))) (defclass asdf-file-info (client-file-info) () (:default-initargs :plist-key :asdf :name "asdf.lisp")) (defclass setup-file-info (client-file-info) () (:default-initargs :plist-key :setup :name "setup.lisp")) (defclass client-tar-file-info (client-file-info) () (:default-initargs :plist-key :client-tar :name "quicklisp.tar")) (define-condition invalid-client-file (error) ((file :initarg :file :reader invalid-client-file-file))) (define-condition badly-sized-client-file (invalid-client-file) ((expected-size :initarg :expected-size :reader badly-sized-client-file-expected-size) (actual-size :initarg :actual-size :reader badly-sized-client-file-actual-size)) (:report (lambda (condition stream) (format stream "Unexpected file size for ~A ~ - expected ~A but got ~A" (invalid-client-file-file condition) (badly-sized-client-file-expected-size condition) (badly-sized-client-file-actual-size condition))))) (defun check-client-file-size (file expected-size) (let ((actual-size (file-size file))) (unless (eql expected-size actual-size) (error 'badly-sized-client-file :file file :expected-size expected-size :actual-size actual-size)))) ;;; TODO: check cryptographic digests too. (defgeneric check-client-file (file client-file-info) (:documentation "Signal an INVALID-CLIENT-FILE error if FILE does not match the metadata in CLIENT-FILE-INFO.") (:method (file client-file-info) (check-client-file-size file (size client-file-info)) client-file-info)) ;;; Structuring and loading information about the Quicklisp client ;;; code (defclass client-info () ((setup-info :reader setup-info :initarg :setup-info) (asdf-info :reader asdf-info :initarg :asdf-info) (client-tar-info :reader client-tar-info :initarg :client-tar-info) (canonical-client-info-url :reader canonical-client-info-url :initarg :canonical-client-info-url) (version :reader version :initarg :version) (subscription-url :reader subscription-url :initarg :subscription-url) (plist :reader plist :initarg :plist) (source-file :reader source-file :initarg :source-file))) (defmethod print-object ((client-info client-info) stream) (print-unreadable-object (client-info stream :type t) (prin1 (version client-info) stream))) (defmethod available-versions-url ((info client-info)) (make-versions-url (subscription-url info))) (defgeneric extract-client-file-info (file-info-class plist) (:method (file-info-class plist) (let* ((instance (make-instance file-info-class)) (key (plist-key instance)) (file-info-plist (getf plist key))) (unless file-info-plist (error "Missing client-info data for ~S" key)) (destructuring-bind (&key url size md5 sha256 &allow-other-keys) file-info-plist (unless (and url size md5 sha256) (error "Missing client-info data for ~S" key)) (reinitialize-instance instance :plist file-info-plist :url url :size size :md5 md5 :sha256 sha256))))) (defun format-client-url (path &rest format-arguments) (if format-arguments (format nil "~A~{~}" *client-base-url* path format-arguments) (format nil "~A~A" *client-base-url* path))) (defun client-info-url-from-version (version) (format-client-url "client/~A/client-info.sexp" version)) (define-condition invalid-client-info (error) ((plist :initarg plist :reader invalid-client-info-plist))) (defun load-client-info (file) (let ((plist (safely-read-file file))) (destructuring-bind (&key subscription-url version canonical-client-info-url &allow-other-keys) plist (make-instance 'client-info :setup-info (extract-client-file-info 'setup-file-info plist) :asdf-info (extract-client-file-info 'asdf-file-info plist) :client-tar-info (extract-client-file-info 'client-tar-file-info plist) :canonical-client-info-url canonical-client-info-url :version version :subscription-url subscription-url :plist plist :source-file (probe-file file))))) (defun mock-client-info () (flet ((mock-client-file-info (class) (make-instance class :size 0 :url "" :md5 "" :sha256 "" :plist nil))) (make-instance 'client-info :version ql-info:*version* :subscription-url (format-client-url "client/quicklisp.sexp") :setup-info (mock-client-file-info 'setup-file-info) :asdf-info (mock-client-file-info 'asdf-file-info) :client-tar-info (mock-client-file-info 'client-tar-file-info)))) (defun fetch-client-info (url) (let ((info-file (qmerge "tmp/client-info.sexp"))) (delete-file-if-exists info-file) (fetch url info-file :quietly t) (handler-case (load-client-info info-file) ;; FIXME: So many other things could go wrong here; I think it ;; would be nice to catch and report them clearly as bogus URLs (invalid-client-info () (error "Invalid client info URL -- ~A" url))))) (defun local-client-info () (let ((info-file (qmerge "client-info.sexp"))) (if (probe-file info-file) (load-client-info info-file) (progn (warn "Missing client-info.sexp, using mock info") (mock-client-info))))) (defun newest-client-info (&optional (info (local-client-info))) (let ((latest (subscription-url info))) (when latest (fetch-client-info latest)))) (defun client-version-lessp (client-info-1 client-info-2) (string-lessp (version client-info-1) (version client-info-2))) (defun client-version () "Return the version for the current local client installation. May or may not be suitable for passing as the :VERSION argument to INSTALL-CLIENT, depending on if it's a standard Quicklisp-provided client." (version (local-client-info))) (defun client-url () "Return an URL suitable for passing as the :URL argument to INSTALL-CLIENT for the current local client installation." (canonical-client-info-url (local-client-info))) (defun available-client-versions () (let ((url (available-versions-url (local-client-info))) (temp-file (qmerge "tmp/client-versions.sexp"))) (when url (handler-case (progn (maybe-fetch-gzipped url temp-file) (prog1 (with-open-file (stream temp-file) (safely-read stream)) (delete-file-if-exists temp-file))) (unexpected-http-status (condition) (unless (url-not-suitable-error-p condition) (error condition))))))) quicklisp/client-update.lisp000066400000000000000000000105361401210150300165010ustar00rootroot00000000000000;;;; client-update.lisp (in-package #:quicklisp-client) (defun fetch-client-file-info (client-file-info output-file) (maybe-fetch-gzipped (file-url client-file-info) output-file) (check-client-file output-file client-file-info) (probe-file output-file)) (defun retirement-directory (base) (let ((suffix 0)) (loop (incf suffix) (let* ((try (format nil "~A-~D" base suffix)) (dir (qmerge (make-pathname :directory (list :relative "retired" try))))) (unless (probe-directory dir) (return dir)))))) (defun retire (directory base) (let ((retirement-home (qmerge "retired/")) (from (truename directory))) (ensure-directories-exist retirement-home) (let* ((*default-pathname-defaults* retirement-home) (to (retirement-directory base))) (rename-directory from to) to))) (defun client-update-scratch-directory (client-info) (qmerge (make-pathname :directory (list :relative "tmp" "client-update" (version client-info))))) (defun %install-client (new-info local-info) (let* ((work-directory (client-update-scratch-directory new-info)) (current-quicklisp-directory (qmerge "quicklisp/")) (new-quicklisp-directory (merge-pathnames "quicklisp/" work-directory)) (local-temp-tar (merge-pathnames "quicklisp.tar" work-directory)) (local-setup (merge-pathnames "setup.lisp" work-directory)) (local-asdf (merge-pathnames "asdf.lisp" work-directory)) (new-client-tar-p (not (info-equal (client-tar-info new-info) (client-tar-info local-info)))) (new-setup-p (not (info-equal (setup-info new-info) (setup-info local-info)))) (new-asdf-p (not (info-equal (asdf-info new-info) (asdf-info local-info))))) (ensure-directories-exist work-directory) ;; Fetch and unpack quicklisp.tar if needed (when new-client-tar-p (fetch-client-file-info (client-tar-info new-info) local-temp-tar) (unpack-tarball local-temp-tar :directory work-directory)) ;; Fetch setup.lisp if needed (when new-setup-p (fetch-client-file-info (setup-info new-info) local-setup)) ;; Fetch asdf.lisp if needed (when new-asdf-p (fetch-client-file-info (asdf-info new-info) local-asdf)) ;; Everything fetched, so move the old stuff away and move the new ;; stuff in (when new-client-tar-p (retire (qmerge "quicklisp/") (format nil "quicklisp-~A" (version local-info))) (rename-directory new-quicklisp-directory current-quicklisp-directory)) (when new-setup-p (replace-file local-setup (qmerge "setup.lisp"))) (when new-asdf-p (replace-file local-asdf (qmerge "asdf.lisp"))) ;; But unconditionally move the new client-info into place (replace-file (source-file new-info) (qmerge "client-info.sexp")) new-info)) (defun update-client (&key (prompt t)) (let* ((local-info (local-client-info)) (newest-info (newest-client-info local-info))) (cond ((null newest-info) (format t "No client update available.~%")) ((client-version-lessp local-info newest-info) (format t "Updating client from version ~A to version ~A.~%" (version local-info) (version newest-info)) (when (or (not prompt) (press-enter-to-continue)) (%install-client newest-info local-info) (format t "~&New Quicklisp client installed. ~ It will take effect on restart.~%"))) (t (format t "The most up-to-date client, version ~A, ~ is already installed.~%" (version local-info))))) t) (defun install-client (&key url version) (unless (or url version) (error "One of ~S or ~S is required" :url :version)) (when (and url version) (error "Only one of ~S or ~S is allowed" :url :version)) (when version (setf url (client-info-url-from-version version))) (let ((local-info (local-client-info)) (new-info (fetch-client-info url))) (%install-client new-info local-info))) quicklisp/client.lisp000066400000000000000000000122231401210150300152140ustar00rootroot00000000000000;;;; client.lisp (in-package #:quicklisp-client) (defvar *quickload-verbose* nil "When NIL, show terse output when quickloading a system. Otherwise, show normal compile and load output.") (defvar *quickload-prompt* nil "When NIL, quickload systems without prompting for enter to continue, otherwise proceed directly without user intervention.") (defvar *quickload-explain* t) (define-condition system-not-quickloadable (error) ((system :initarg :system :reader not-quickloadable-system))) (defun maybe-silence (silent stream) (or (and silent (make-broadcast-stream)) stream)) (defgeneric quickload (systems &key verbose silent prompt explain &allow-other-keys) (:documentation "Load SYSTEMS the quicklisp way. SYSTEMS is a designator for a list of things to be loaded.") (:method (systems &key (prompt *quickload-prompt*) (silent nil) (verbose *quickload-verbose*) &allow-other-keys) (let ((*standard-output* (maybe-silence silent *standard-output*)) (*trace-output* (maybe-silence silent *trace-output*))) (unless (listp systems) (setf systems (list systems))) (dolist (thing systems systems) (flet ((ql () (autoload-system-and-dependencies thing :prompt prompt))) (tagbody :start (restart-case (if verbose (ql) (call-with-quiet-compilation #'ql)) (register-local-projects () :report "Register local projects and try again." (register-local-projects) (go :start))))))))) (defmethod quickload :around (systems &key verbose prompt explain &allow-other-keys) (declare (ignorable systems verbose prompt explain)) (with-consistent-dists (call-next-method))) (defun system-list () (provided-systems t)) (defun update-dist (dist &key (prompt t)) (when (stringp dist) (setf dist (find-dist dist))) (let ((new (available-update dist))) (cond (new (show-update-report dist new) (when (or (not prompt) (press-enter-to-continue)) (update-in-place dist new))) ((not (subscribedp dist)) (format t "~&You are not subscribed to ~S." (name dist))) (t (format t "~&You already have the latest version of ~S: ~A.~%" (name dist) (version dist)))))) (defun update-all-dists (&key (prompt t)) (let ((dists (remove-if-not 'subscribedp (all-dists)))) (format t "~&~D dist~:P to check.~%" (length dists)) (dolist (old dists) (with-simple-restart (skip "Skip update of dist ~S" (name old)) (update-dist old :prompt prompt))))) (defun available-dist-versions (name) (available-versions (find-dist-or-lose name))) (defun help () "For help with Quicklisp, see http://www.quicklisp.org/beta/") (defun uninstall (system-name) (let ((system (find-system system-name))) (cond (system (ql-dist:uninstall system)) (t (warn "Unknown system ~S" system-name) nil)))) (defun uninstall-dist (name) (let ((dist (find-dist name))) (when dist (ql-dist:uninstall dist)))) (defun write-asdf-manifest-file (output-file &key (if-exists :rename-and-delete) exclude-local-projects) "Write a list of system file pathnames to OUTPUT-FILE, one per line, in order of descending QL-DIST:PREFERENCE." (when (or (eql output-file nil) (eql output-file t)) (setf output-file (qmerge "manifest.txt"))) (with-open-file (stream output-file :direction :output :if-exists if-exists) (unless exclude-local-projects (register-local-projects) (dolist (system-file (list-local-projects)) (let* ((enough (enough-namestring system-file output-file)) (native (native-namestring enough))) (write-line native stream)))) (with-consistent-dists (let ((systems (provided-systems t)) (already-seen (make-hash-table :test 'equal))) (dolist (system (sort systems #'> :key #'preference)) ;; FIXME: find-asdf-system-file does another find-system ;; behind the scenes. Bogus. Should be a better way to go ;; from system object to system file. (let* ((system-file (find-asdf-system-file (name system))) (enough (and system-file (enough-namestring system-file output-file))) (native (and enough (native-namestring enough)))) (when (and native (not (gethash native already-seen))) (setf (gethash native already-seen) native) (format stream "~A~%" native))))))) (probe-file output-file)) (defun where-is-system (name) "Return the pathname to the source directory of ASDF system with the given NAME, or NIL if no system by that name can be found known." (let ((system (asdf:find-system name nil))) (when system (asdf:system-source-directory system)))) quicklisp/config.lisp000066400000000000000000000025141401210150300152050ustar00rootroot00000000000000;;;; config.lisp (in-package #:ql-config) (defun config-value-file-pathname (path) (let ((bad-position (position #\Space path))) (when bad-position (error "Space not allowed at position ~D in ~S" bad-position path))) (let* ((space-path (substitute #\Space #\/ path)) (split (split-spaces space-path)) (directory-parts (butlast split)) (name (first (last split))) (base (qmerge "config/"))) (merge-pathnames (make-pathname :name name :type "txt" :directory (list* :relative directory-parts)) base))) (defun config-value (path) (let ((file (config-value-file-pathname path))) (with-open-file (stream file :if-does-not-exist nil) (when stream (values (read-line stream nil)))))) (defun (setf config-value) (new-value path) (let ((file (config-value-file-pathname path))) (typecase new-value (null (delete-file-if-exists file)) (string (ensure-directories-exist file) (with-open-file (stream file :direction :output :if-does-not-exist :create :if-exists :rename-and-delete) (write-line new-value stream))) (t (error "Bad config value ~S; must be a string or NIL" new-value))))) quicklisp/deflate.lisp000066400000000000000000001030151401210150300153420ustar00rootroot00000000000000;;;; Deflate --- RFC 1951 Deflate Decompression ;;;; ;;;; Copyright (C) 2000-2009 PMSF IT Consulting Pierre R. Mai. ;;;; ;;;; Permission is hereby granted, free of charge, to any person obtaining ;;;; a copy of this software and associated documentation files (the ;;;; "Software"), to deal in the Software without restriction, including ;;;; without limitation the rights to use, copy, modify, merge, publish, ;;;; distribute, sublicense, and/or sell copies of the Software, and to ;;;; permit persons to whom the Software is furnished to do so, subject to ;;;; the following conditions: ;;;; ;;;; The above copyright notice and this permission notice shall be ;;;; included in all copies or substantial portions of the Software. ;;;; ;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;;;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR ;;;; OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ;;;; ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR ;;;; OTHER DEALINGS IN THE SOFTWARE. ;;;; ;;;; Except as contained in this notice, the name of the author shall ;;;; not be used in advertising or otherwise to promote the sale, use or ;;;; other dealings in this Software without prior written authorization ;;;; from the author. ;;;; ;;;; $Id: 377d3a33e9db5a3b54c850619183ee555a41b894 $ (cl:in-package #:ql-gunzipper) ;;;; %File Description: ;;;; ;;;; This file contains routines implementing the RFC 1951 Deflate ;;;; Compression and/or Decompression method, as used by e.g. gzip and ;;;; other compression and archiving tools and protocols. It also ;;;; implements handling routines for zlib-style (RFC 1950) and ;;;; gzip-style (RFC 1952) wrappers around raw Deflate streams. ;;;; ;;;; The main entry points are the functions inflate-stream, and its ;;;; cousins inflate-zlib-stream and inflate-gzip-stream, which take ;;;; an input-stream and an output-stream as their arguments, and ;;;; inflate the RFC 1951, RFC 1950 or RFC 1952-style deflate formats ;;;; from the input-stream to the output-stream. ;;;; ;;; ;;; Conditions ;;; (define-condition decompression-error (simple-error) ()) (define-condition deflate-decompression-error (decompression-error) () (:report (lambda (c s) (with-standard-io-syntax (let ((*print-readably* nil)) (format s "Error detected during deflate decompression: ~?" (simple-condition-format-control c) (simple-condition-format-arguments c))))))) (define-condition zlib-decompression-error (decompression-error) () (:report (lambda (c s) (with-standard-io-syntax (let ((*print-readably* nil)) (format s "Error detected during zlib decompression: ~?" (simple-condition-format-control c) (simple-condition-format-arguments c))))))) (define-condition gzip-decompression-error (decompression-error) () (:report (lambda (c s) (with-standard-io-syntax (let ((*print-readably* nil)) (format s "Error detected during zlib decompression: ~?" (simple-condition-format-control c) (simple-condition-format-arguments c))))))) ;;; ;;; Adler-32 Checksums ;;; (defconstant +adler-32-start-value+ 1 "Start value for Adler-32 checksums as per RFC 1950.") (defconstant +adler-32-base+ 65521 "Base value for Adler-32 checksums as per RFC 1950.") (declaim (ftype (function ((unsigned-byte 32) (simple-array (unsigned-byte 8) (*)) fixnum) (unsigned-byte 32)) update-adler32-checksum)) (defun update-adler32-checksum (crc buffer end) (declare (type (unsigned-byte 32) crc) (type (simple-array (unsigned-byte 8) (*)) buffer) (type fixnum end) (optimize (speed 3) (debug 0) (space 0) (safety 0)) #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) (let ((s1 (ldb (byte 16 0) crc)) (s2 (ldb (byte 16 16) crc))) (declare (type (unsigned-byte 32) s1 s2)) (dotimes (i end) (declare (type fixnum i)) (setq s1 (mod (+ s1 (aref buffer i)) +adler-32-base+) s2 (mod (+ s2 s1) +adler-32-base+))) (dpb s2 (byte 16 16) s1))) ;;; ;;; CRC-32 Checksums ;;; (defconstant +crc-32-start-value+ 0 "Start value for CRC-32 checksums as per RFC 1952.") (defconstant +crc-32-polynomial+ #xedb88320 "CRC-32 Polynomial as per RFC 1952.") (declaim (ftype #-lispworks (function () (simple-array (unsigned-byte 32) (256))) #+lispworks (function () (sys:simple-int32-vector 256)) generate-crc32-table)) (defun generate-crc32-table () (let ((result #-lispworks (make-array 256 :element-type '(unsigned-byte 32)) #+lispworks (sys:make-simple-int32-vector 256))) (dotimes (i #-lispworks (length result) #+lispworks 256 result) (let ((cur i)) (dotimes (k 8) (setq cur (if (= 1 (logand cur 1)) (logxor (ash cur -1) +crc-32-polynomial+) (ash cur -1)))) #-lispworks (setf (aref result i) cur) #+lispworks (setf (sys:int32-aref result i) (sys:integer-to-int32 (dpb (ldb (byte 32 0) cur) (byte 32 0) (if (logbitp 31 cur) -1 0)))))))) (declaim (ftype (function ((unsigned-byte 32) (simple-array (unsigned-byte 8) (*)) fixnum) (unsigned-byte 32)) update-crc32-checksum)) #-lispworks (defun update-crc32-checksum (crc buffer end) (declare (type (unsigned-byte 32) crc) (type (simple-array (unsigned-byte 8) (*)) buffer) (type fixnum end) (optimize (speed 3) (debug 0) (space 0) (safety 0)) #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) (let ((table (load-time-value (generate-crc32-table))) (cur (logxor crc #xffffffff))) (declare (type (simple-array (unsigned-byte 32) (256)) table) (type (unsigned-byte 32) cur)) (dotimes (i end) (declare (type fixnum i)) (let ((index (logand #xff (logxor cur (aref buffer i))))) (declare (type (unsigned-byte 8) index)) (setq cur (logxor (aref table index) (ash cur -8))))) (logxor cur #xffffffff))) #+lispworks (defun update-crc32-checksum (crc buffer end) (declare (type (unsigned-byte 32) crc) (type (simple-array (unsigned-byte 8) (*)) buffer) (type fixnum end) (optimize (speed 3) (debug 0) (space 0) (safety 0) (float 0))) (let ((table (load-time-value (generate-crc32-table))) (cur (sys:int32-lognot (sys:integer-to-int32 (dpb (ldb (byte 32 0) crc) (byte 32 0) (if (logbitp 31 crc) -1 0)))))) (declare (type (sys:simple-int32-vector 256) table) (type sys:int32 cur)) (dotimes (i end) (declare (type fixnum i)) (let ((index (sys:int32-to-integer (sys:int32-logand #xff (sys:int32-logxor cur (aref buffer i)))))) (declare (type fixnum index)) (setq cur (sys:int32-logxor (sys:int32-aref table index) (sys:int32-logand #x00ffffff (sys:int32>> cur 8)))))) (ldb (byte 32 0) (sys:int32-to-integer (sys:int32-lognot cur))))) ;;; ;;; Helper Data Structures: Sliding Window Stream ;;; (eval-when (:compile-toplevel :load-toplevel :execute) (defconstant +sliding-window-size+ 32768 "Size of sliding window for RFC 1951 Deflate compression scheme.")) (defstruct sliding-window-stream (stream nil :type stream :read-only t) (buffer (make-array +sliding-window-size+ :element-type '(unsigned-byte 8)) :type (simple-array (unsigned-byte 8) (#.+sliding-window-size+)) :read-only t) (buffer-end 0 :type fixnum) (checksum nil :type symbol :read-only t) (checksum-value 0 :type (unsigned-byte 32))) (declaim (inline sliding-window-stream-write-byte)) (defun sliding-window-stream-write-byte (stream byte) (declare (type sliding-window-stream stream) (type (unsigned-byte 8) byte) #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note)) "Write a single byte to the sliding-window-stream." (let ((end (sliding-window-stream-buffer-end stream))) (declare (type fixnum end)) (unless (< end +sliding-window-size+) (write-sequence (sliding-window-stream-buffer stream) (sliding-window-stream-stream stream)) (case (sliding-window-stream-checksum stream) (:adler-32 (setf (sliding-window-stream-checksum-value stream) (update-adler32-checksum (sliding-window-stream-checksum-value stream) (sliding-window-stream-buffer stream) +sliding-window-size+))) (:crc-32 (setf (sliding-window-stream-checksum-value stream) (update-crc32-checksum (sliding-window-stream-checksum-value stream) (sliding-window-stream-buffer stream) +sliding-window-size+)))) (setq end 0)) (setf (aref (sliding-window-stream-buffer stream) end) byte (sliding-window-stream-buffer-end stream) (1+ end)))) (defun sliding-window-stream-flush (stream) (declare (type sliding-window-stream stream)) "Flush any remaining buffered bytes from the stream." (let ((end (sliding-window-stream-buffer-end stream))) (declare (type fixnum end)) (unless (zerop end) (case (sliding-window-stream-checksum stream) (:adler-32 (setf (sliding-window-stream-checksum-value stream) (update-adler32-checksum (sliding-window-stream-checksum-value stream) (sliding-window-stream-buffer stream) end))) (:crc-32 (setf (sliding-window-stream-checksum-value stream) (update-crc32-checksum (sliding-window-stream-checksum-value stream) (sliding-window-stream-buffer stream) end)))) (write-sequence (sliding-window-stream-buffer stream) (sliding-window-stream-stream stream) :end end)))) (defun sliding-window-stream-copy-bytes (stream distance length) (declare (type sliding-window-stream stream) (type fixnum distance length)) "Copy a number of bytes from the current sliding window." (let* ((end (sliding-window-stream-buffer-end stream)) (start (mod (- end distance) +sliding-window-size+)) (buffer (sliding-window-stream-buffer stream))) (declare (type fixnum end start) (type (simple-array (unsigned-byte 8) (#.+sliding-window-size+)) buffer)) (dotimes (i length) (sliding-window-stream-write-byte stream (aref buffer (mod (+ start i) +sliding-window-size+)))))) ;;; ;;; Helper Data Structures: Bit-wise Input Stream ;;; (defstruct bit-stream (stream nil :type stream :read-only t) (next-byte 0 :type fixnum) (bits 0 :type (unsigned-byte 29)) (bit-count 0 :type (unsigned-byte 8))) (declaim (inline bit-stream-get-byte)) (defun bit-stream-get-byte (stream) (declare (type bit-stream stream)) "Read another byte from the underlying stream." (the (unsigned-byte 8) (read-byte (bit-stream-stream stream)))) (declaim (inline bit-stream-read-bits)) (defun bit-stream-read-bits (stream bits) (declare (type bit-stream stream) ;; [quicklisp-added] ;; FIXME: This might be fixed soon in ECL. ;; http://article.gmane.org/gmane.lisp.ecl.general/7659 #-ecl (type (unsigned-byte 8) bits)) "Read single or multiple bits from the given bit-stream." (loop while (< (bit-stream-bit-count stream) bits) do ;; Fill bits (setf (bit-stream-bits stream) (logior (bit-stream-bits stream) (the (unsigned-byte 29) (ash (bit-stream-get-byte stream) (bit-stream-bit-count stream)))) (bit-stream-bit-count stream) (+ (bit-stream-bit-count stream) 8))) ;; Return properly masked bits (if (= (bit-stream-bit-count stream) bits) (prog1 (bit-stream-bits stream) (setf (bit-stream-bits stream) 0 (bit-stream-bit-count stream) 0)) (prog1 (ldb (byte bits 0) (bit-stream-bits stream)) (setf (bit-stream-bits stream) (ash (bit-stream-bits stream) (- bits)) (bit-stream-bit-count stream) (- (bit-stream-bit-count stream) bits))))) (declaim (inline bit-stream-copy-block)) (defun bit-stream-copy-block (stream out-stream) (declare (type bit-stream stream) (type sliding-window-stream out-stream) (optimize (speed 3) (safety 0) (space 0) (debug 0))) "Copy a given block of bytes directly from the underlying stream." ;; Skip any remaining unprocessed bits (setf (bit-stream-bits stream) 0 (bit-stream-bit-count stream) 0) ;; Get LEN/NLEN and copy bytes (let* ((len (logior (bit-stream-get-byte stream) (ash (bit-stream-get-byte stream) 8))) (nlen (ldb (byte 16 0) (lognot (logior (bit-stream-get-byte stream) (ash (bit-stream-get-byte stream) 8)))))) (unless (= len nlen) (error 'deflate-decompression-error :format-control "Block length mismatch for stored block: LEN(~D) vs. NLEN(~D)!" :format-arguments (list len nlen))) (dotimes (i len) (sliding-window-stream-write-byte out-stream (bit-stream-get-byte stream))))) ;;; ;;; Huffman Coding ;;; ;;; A decode-tree struct contains all information necessary to decode ;;; the given canonical huffman code. Note that length-count contains ;;; the number of codes with a given length for each length, whereas ;;; the code-symbols array contains the symbols corresponding to the ;;; codes in canoical order of the codes. ;;; ;;; Decoding then uses this information and the principles underlying ;;; canonical huffman codes to determine whether the currently ;;; collected word falls between the first code and the last code for ;;; the current length, and if so, uses the offset to determine the ;;; code's symbol. Otherwise more bits are needed. (defstruct decode-tree (length-count (make-array 16 :element-type 'fixnum :initial-element 0) :type (simple-array fixnum (*)) :read-only t) (code-symbols (make-array 16 :element-type 'fixnum :initial-element 0) :type (simple-array fixnum (*)))) (defun make-huffman-decode-tree (code-lengths) "Construct a huffman decode-tree for the canonical huffman code with the code lengths of each symbol given in the input array." (let* ((max-length (reduce #'max code-lengths :initial-value 0)) (next-code (make-array (1+ max-length) :element-type 'fixnum :initial-element 0)) (code-symbols (make-array (length code-lengths) :element-type 'fixnum :initial-element 0)) (length-count (make-array (1+ max-length) :element-type 'fixnum :initial-element 0))) ;; Count length occurences and calculate offsets of smallest codes (loop for index from 1 to max-length for code = 0 then (+ code (aref length-count (1- index))) do (setf (aref next-code index) code) initially ;; Count length occurences (loop for length across code-lengths do (incf (aref length-count length)) finally (setf (aref length-count 0) 0))) ;; Construct code symbols mapping (loop for length across code-lengths for index upfrom 0 unless (zerop length) do (setf (aref code-symbols (aref next-code length)) index) (incf (aref next-code length))) ;; Return result (make-decode-tree :length-count length-count :code-symbols code-symbols))) (declaim (inline read-huffman-code)) (defun read-huffman-code (bit-stream decode-tree) (declare (type bit-stream bit-stream) (type decode-tree decode-tree) (optimize (speed 3) (safety 0) (space 0) (debug 0))) "Read the next huffman code word from the given bit-stream and return its decoded symbol, for the huffman code given by decode-tree." (loop with length-count of-type (simple-array fixnum (*)) = (decode-tree-length-count decode-tree) with code-symbols of-type (simple-array fixnum (*)) = (decode-tree-code-symbols decode-tree) for code of-type fixnum = (bit-stream-read-bits bit-stream 1) then (+ (* code 2) (bit-stream-read-bits bit-stream 1)) for index of-type fixnum = 0 then (+ index count) for first of-type fixnum = 0 then (* (+ first count) 2) for length of-type fixnum upfrom 1 below (length length-count) for count = (aref length-count length) thereis (when (< code (the fixnum (+ first count))) (aref code-symbols (+ index (- code first)))) finally (error 'deflate-decompression-error :format-control "Corrupted Data detected during decompression: ~ Incorrect huffman code (~X) in huffman decode!" :format-arguments (list code)))) ;;; ;;; Standard Huffman Tables ;;; (defparameter *std-lit-decode-tree* (make-huffman-decode-tree (concatenate 'vector (make-sequence 'vector 144 :initial-element 8) (make-sequence 'vector 112 :initial-element 9) (make-sequence 'vector 24 :initial-element 7) (make-sequence 'vector 8 :initial-element 8)))) (defparameter *std-dist-decode-tree* (make-huffman-decode-tree (make-sequence 'vector 32 :initial-element 5))) ;;; ;;; Dynamic Huffman Table Handling ;;; (defparameter *code-length-entry-order* #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15) "Order of Code Length Tree Code Lengths.") (defun decode-code-length-entries (bit-stream count decode-tree) "Decode the given number of code length entries from the bit-stream using the given decode-tree, and return a corresponding array of code lengths for further processing." (do ((result (make-array count :element-type 'fixnum :initial-element 0)) (index 0)) ((>= index count) result) (let ((code (read-huffman-code bit-stream decode-tree))) (ecase code ((0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) (setf (aref result index) code) (incf index)) (16 (let ((length (+ 3 (bit-stream-read-bits bit-stream 2)))) (dotimes (i length) (setf (aref result (+ index i)) (aref result (1- index)))) (incf index length))) (17 (let ((length (+ 3 (bit-stream-read-bits bit-stream 3)))) (dotimes (i length) (setf (aref result (+ index i)) 0)) (incf index length))) (18 (let ((length (+ 11 (bit-stream-read-bits bit-stream 7)))) (dotimes (i length) (setf (aref result (+ index i)) 0)) (incf index length))))))) (defun decode-huffman-tables (bit-stream) "Decode the stored huffman tables from the given bit-stream, returning the corresponding decode-trees for literals/length and distance codes." (let* ((hlit (bit-stream-read-bits bit-stream 5)) (hdist (bit-stream-read-bits bit-stream 5)) (hclen (bit-stream-read-bits bit-stream 4))) ;; Construct Code Length Decode Tree (let ((cl-decode-tree (loop with code-lengths = (make-array 19 :element-type '(unsigned-byte 8) :initial-element 0) for index from 0 below (+ hclen 4) for code-length = (bit-stream-read-bits bit-stream 3) for code-index = (aref *code-length-entry-order* index) do (setf (aref code-lengths code-index) code-length) finally (return (make-huffman-decode-tree code-lengths))))) ;; Decode Code Length Table and generate separate huffman trees (let ((entries (decode-code-length-entries bit-stream (+ hlit 257 hdist 1) cl-decode-tree))) (values (make-huffman-decode-tree (subseq entries 0 (+ hlit 257))) (make-huffman-decode-tree (subseq entries (+ hlit 257)))))))) ;;; ;;; Compressed Block Handling ;;; (declaim (inline decode-length-entry)) (defun decode-length-entry (symbol bit-stream) "Decode the given length symbol into a proper length specification." (cond ((<= symbol 264) (- symbol 254)) ((<= symbol 268) (+ 11 (* (- symbol 265) 2) (bit-stream-read-bits bit-stream 1))) ((<= symbol 272) (+ 19 (* (- symbol 269) 4) (bit-stream-read-bits bit-stream 2))) ((<= symbol 276) (+ 35 (* (- symbol 273) 8) (bit-stream-read-bits bit-stream 3))) ((<= symbol 280) (+ 67 (* (- symbol 277) 16) (bit-stream-read-bits bit-stream 4))) ((<= symbol 284) (+ 131 (* (- symbol 281) 32) (bit-stream-read-bits bit-stream 5))) ((= symbol 285) 258) (t (error 'deflate-decompression-error :format-control "Strange Length Code in bitstream: ~D" :format-arguments (list symbol))))) (declaim (inline decode-distance-entry)) (defun decode-distance-entry (symbol bit-stream) "Decode the given distance symbol into a proper distance specification." (cond ((<= symbol 3) (1+ symbol)) (t (multiple-value-bind (order offset) (truncate symbol 2) (let* ((extra-bits (1- order)) (factor (ash 1 extra-bits))) (+ (1+ (ash 1 order)) (* offset factor) (bit-stream-read-bits bit-stream extra-bits))))))) (defun decode-huffman-block (bit-stream window-stream lit-decode-tree dist-decode-tree) "Decode the huffman code block using the huffman codes given by lit-decode-tree and dist-decode-tree." (do ((symbol (read-huffman-code bit-stream lit-decode-tree) (read-huffman-code bit-stream lit-decode-tree))) ((= symbol 256)) (cond ((<= symbol 255) (sliding-window-stream-write-byte window-stream symbol)) (t (let ((length (decode-length-entry symbol bit-stream)) (distance (decode-distance-entry (read-huffman-code bit-stream dist-decode-tree) bit-stream))) (sliding-window-stream-copy-bytes window-stream distance length)))))) ;;; ;;; Block Handling Code ;;; (defun decode-block (bit-stream window-stream) "Decompress a block read from bit-stream into window-stream." (let* ((finalp (not (zerop (bit-stream-read-bits bit-stream 1)))) (type (bit-stream-read-bits bit-stream 2))) (ecase type (#b00 (bit-stream-copy-block bit-stream window-stream)) (#b01 (decode-huffman-block bit-stream window-stream *std-lit-decode-tree* *std-dist-decode-tree*)) (#b10 (multiple-value-bind (lit-decode-tree dist-decode-tree) (decode-huffman-tables bit-stream) (decode-huffman-block bit-stream window-stream lit-decode-tree dist-decode-tree))) (#b11 (error 'deflate-decompression-error :format-control "Encountered Reserved Block Type ~D!" :format-arguments (list type)))) (not finalp))) ;;; ;;; ZLIB - RFC 1950 handling ;;; (defun parse-zlib-header (input-stream) "Parse a ZLIB-style header as per RFC 1950 from the input-stream and return the compression-method, compression-level dictionary-id and flags fields of the header as return values. Checks the header for corruption and signals a zlib-decompression-error in case of corruption." (let ((compression-method (read-byte input-stream)) (flags (read-byte input-stream))) (unless (zerop (mod (+ (* compression-method 256) flags) 31)) (error 'zlib-decompression-error :format-control "Corrupted Header ~2,'0X,~2,'0X!" :format-arguments (list compression-method flags))) (let ((dict (unless (zerop (ldb (byte 1 5) flags)) (parse-zlib-checksum input-stream)))) (values (ldb (byte 4 0) compression-method) (ldb (byte 4 4) compression-method) dict (ldb (byte 2 6) flags))))) (defun parse-zlib-checksum (input-stream) (+ (* (read-byte input-stream) 256 256 256) (* (read-byte input-stream) 256 256) (* (read-byte input-stream) 256) (read-byte input-stream))) (defun parse-zlib-footer (input-stream) "Parse the ZLIB-style footer as per RFC 1950 from the input-stream and return the Adler-32 checksum contained in the footer as its return value." (parse-zlib-checksum input-stream)) ;;; ;;; GZIP - RFC 1952 handling ;;; (defconstant +gzip-header-id1+ 31 "GZIP Header Magic Value ID1 as per RFC 1952.") (defconstant +gzip-header-id2+ 139 "GZIP Header Magic Value ID2 as per RFC 1952.") (defun parse-gzip-header (input-stream) "Parse a GZIP-style header as per RFC 1952 from the input-stream and return the compression-method, text-flag, modification time, XFLAGS, OS, FEXTRA flags, filename, comment and CRC16 fields of the header as return values (or nil if any given field is not present). Checks the header for magic values and correct flags settings and signals a gzip-decompression-error in case of incorrect or unsupported magic values or flags." (let ((id1 (read-byte input-stream)) (id2 (read-byte input-stream)) (compression-method (read-byte input-stream)) (flags (read-byte input-stream))) (unless (and (= id1 +gzip-header-id1+) (= id2 +gzip-header-id2+)) (error 'gzip-decompression-error :format-control "Header missing magic values ~2,'0X,~2,'0X (got ~2,'0X,~2,'0X instead)!" :format-arguments (list +gzip-header-id1+ +gzip-header-id2+ id1 id2))) (unless (= compression-method 8) (error 'gzip-decompression-error :format-control "Unknown compression-method in Header ~2,'0X!" :format-arguments (list compression-method))) (unless (zerop (ldb (byte 3 5) flags)) (error 'gzip-decompression-error :format-control "Unknown flags in Header ~2,'0X!" :format-arguments (list flags))) (values compression-method ;; FTEXT (= 1 (ldb (byte 1 0) flags)) ;; MTIME (parse-gzip-mtime input-stream) ;; XFLAGS (read-byte input-stream) ;; OS (read-byte input-stream) ;; FEXTRA (unless (zerop (ldb (byte 1 2) flags)) (parse-gzip-extra input-stream)) ;; FNAME (unless (zerop (ldb (byte 1 3) flags)) (parse-gzip-string input-stream)) ;; FCOMMENT (unless (zerop (ldb (byte 1 4) flags)) (parse-gzip-string input-stream)) ;; CRC16 (unless (zerop (ldb (byte 1 1) flags)) (+ (read-byte input-stream) (* (read-byte input-stream 256))))))) (defun parse-gzip-mtime (input-stream) (let ((time (+ (read-byte input-stream) (* (read-byte input-stream) 256) (* (read-byte input-stream) 256 256) (* (read-byte input-stream) 256 256 256)))) (if (zerop time) nil (+ time 2208988800)))) (defun parse-gzip-extra (input-stream) (let* ((length (+ (read-byte input-stream) (* (read-byte input-stream) 256))) (result (make-array length :element-type '(unsigned-byte 8)))) (read-sequence result input-stream) result)) (defun parse-gzip-string (input-stream) (with-output-to-string (string) (loop for value = (read-byte input-stream) until (zerop value) do (write-char (code-char value) string)))) (defun parse-gzip-checksum (input-stream) (+ (read-byte input-stream) (* (read-byte input-stream) 256) (* (read-byte input-stream) 256 256) (* (read-byte input-stream) 256 256 256))) (defun parse-gzip-footer (input-stream) "Parse the GZIP-style footer as per RFC 1952 from the input-stream and return the CRC-32 checksum and ISIZE fields contained in the footer as its return values." (values (parse-gzip-checksum input-stream) ;; ISIZE (+ (read-byte input-stream) (* (read-byte input-stream) 256) (* (read-byte input-stream) 256 256) (* (read-byte input-stream) 256 256 256)))) ;;; ;;; Main Entry Points ;;; (defun inflate-stream (input-stream output-stream &key checksum) "Inflate the RFC 1951 data from the given input stream into the given output stream, which are required to have an element-type of (unsigned-byte 8). If checksum is given, it indicates the checksumming algorithm to employ in calculating a checksum of the expanded content, which is then returned from this function. Valid values are :adler-32 for Adler-32 checksum (see RFC 1950), or :crc-32 for CRC-32 as per ISO 3309 (see RFC 1952, ZIP)." (loop with window-stream = (make-sliding-window-stream :stream output-stream :checksum checksum :checksum-value (ecase checksum ((nil) 0) (:crc-32 +crc-32-start-value+) (:adler-32 +adler-32-start-value+))) with bit-stream = (make-bit-stream :stream input-stream) while (decode-block bit-stream window-stream) finally (sliding-window-stream-flush window-stream) (when checksum (return (sliding-window-stream-checksum-value window-stream))))) (defun inflate-zlib-stream (input-stream output-stream &key check-checksum) "Inflate the RFC 1950 zlib data from the given input stream into the given output stream, which are required to have an element-type of (unsigned-byte 8). This returns the Adler-32 checksum of the file as its first return value, with the compression level as its second return value. Note that it is the responsibility of the caller to check whether the expanded data matches the Adler-32 checksum, unless the check-checksum keyword argument is set to true, in which case the checksum is checked internally and a zlib-decompression-error is signalled if they don't match." (multiple-value-bind (cm cinfo dictid flevel) (parse-zlib-header input-stream) (unless (= cm 8) (error 'zlib-decompression-error :format-control "Unknown compression method ~D!" :format-arguments (list cm))) (unless (<= cinfo 7) (error 'zlib-decompression-error :format-control "Unsupported sliding window size 2^~D = ~D!" :format-arguments (list (+ 8 cinfo) (expt 2 (+ 8 cinfo))))) (unless (null dictid) (error 'zlib-decompression-error :format-control "Unknown preset dictionary id ~8,'0X!" :format-arguments (list dictid))) (let ((checksum-new (inflate-stream input-stream output-stream :checksum (when check-checksum :adler-32))) (checksum-old (parse-zlib-footer input-stream))) (when (and check-checksum (not (= checksum-old checksum-new))) (error 'zlib-decompression-error :format-control "Checksum mismatch for decompressed stream: ~8,'0X != ~8,'0X!" :format-arguments (list checksum-old checksum-new))) (values checksum-old flevel)))) (defun inflate-gzip-stream (input-stream output-stream &key check-checksum) "Inflate the RFC 1952 gzip data from the given input stream into the given output stream, which are required to have an element-type of (unsigned-byte 8). This returns the CRC-32 checksum of the file as its first return value, with any filename, modification time, and comment fields as further return values or nil if not present. Note that it is the responsibility of the caller to check whether the expanded data matches the CRC-32 checksum, unless the check-checksum keyword argument is set to true, in which case the checksum is checked internally and a gzip-decompression-error is signalled if they don't match." (multiple-value-bind (cm ftext mtime xfl os fextra fname fcomment) (parse-gzip-header input-stream) (declare (ignore ftext xfl os fextra)) (unless (= cm 8) (error 'gzip-decompression-error :format-control "Unknown compression method ~D!" :format-arguments (list cm))) (let ((checksum-new (inflate-stream input-stream output-stream :checksum (when check-checksum :crc-32))) (checksum-old (parse-gzip-footer input-stream))) ;; Handle Checksums (when (and check-checksum (not (= checksum-old checksum-new))) (error 'gzip-decompression-error :format-control "Checksum mismatch for decompressed stream: ~8,'0X != ~8,'0X!" :format-arguments (list checksum-old checksum-new))) (values checksum-old fname mtime fcomment)))) (defun gunzip (input-file output-file) (with-open-file (input input-file :element-type '(unsigned-byte 8)) (with-open-file (output output-file :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (inflate-gzip-stream input output))) (probe-file output-file)) quicklisp/dist-update.lisp000066400000000000000000000154521401210150300161700ustar00rootroot00000000000000;;;; dist-update.lisp (in-package #:ql-dist) (defgeneric available-update (dist) (:documentation "If an update is available for DIST, return the update as an uninstalled dist object. Otherwise, return NIL.")) (defgeneric update-release-differences (old-dist new-dist) (:documentation "Compare OLD-DIST to NEW-DIST and return three lists as multiple values: new releases \(present in NEW-DIST but not OLD-DIST), changed releases \(present in both dists but different in some way), and removed releases \(present in OLD-DIST but not NEW-DIST). The list of changed releases is a list of two-element lists, with each two-element list having first the old release object and then the new release object.")) (defgeneric show-update-report (old-dist new-dist) (:documentation "Display a description of the update from OLD-DIST to NEW-DIST.")) (defgeneric update-in-place (old-dist new-dist) (:documentation "Update OLD-DIST to NEW-DIST in place.")) (defmethod available-update ((dist dist)) (let ((url (distinfo-subscription-url dist)) (target (qmerge "tmp/distinfo-update/distinfo.txt")) (update-directory (qmerge "tmp/distinfo-update/"))) (when (probe-directory update-directory) (delete-directory-tree (qmerge "tmp/distinfo-update/"))) (when url (ensure-directories-exist target) (fetch url target :quietly t) (let ((new (make-dist-from-file target))) (setf (base-directory new) (make-pathname :name nil :type nil :version nil :defaults target)) (when (and (string= (name dist) (name new)) (string/= (version dist) (version new))) new))))) (defmethod update-release-differences ((old-dist dist) (new-dist dist)) (let ((old-releases (provided-releases old-dist)) (new-releases (provided-releases new-dist)) (new '()) (updated '()) (removed '()) (old-by-name (make-hash-table :test 'equalp))) (dolist (release old-releases) (setf (gethash (name release) old-by-name) release)) (dolist (new-release new-releases) (let* ((name (name new-release)) (old-release (gethash name old-by-name))) (remhash name old-by-name) (cond ((not old-release) (push new-release new)) ((not (equal (archive-content-sha1 new-release) (archive-content-sha1 old-release))) (push (list old-release new-release) updated))))) (maphash (lambda (name old-release) (declare (ignore name)) (push old-release removed)) old-by-name) (values (nreverse new) (nreverse updated) (sort removed #'string< :key #'prefix)))) (defmethod show-update-report ((old-dist dist) (new-dist dist)) (multiple-value-bind (new updated removed) (update-release-differences old-dist new-dist) (format t "Changes from ~A ~A to ~A ~A:~%" (name old-dist) (version old-dist) (name new-dist) (version new-dist)) (when new (format t "~& New projects:~%") (format t "~{ ~A~%~}" (mapcar #'prefix new))) (when updated (format t "~% Updated projects:~%") (loop for (old-release new-release) in updated do (format t " ~A -> ~A~%" (prefix old-release) (prefix new-release)))) (when removed (format t "~% Removed projects:~%") (format t "~{ ~A~%~}" (mapcar #'prefix removed))))) (defun clear-dist-systems (dist) (dolist (system (provided-systems dist)) (asdf:clear-system (name system)))) (defmethod update-in-place :before ((old-dist dist) (new-dist dist)) ;; Make sure ASDF will reload any systems at their new locations (clear-dist-systems old-dist)) (defmethod update-in-place :after ((old-dist dist) (new-dist dist)) (clean new-dist)) (defmethod update-in-place ((old-dist dist) (new-dist dist)) (flet ((remove-installed (type) (let ((wild (merge-pathnames (make-pathname :directory (list :relative "installed" type) :name :wild :type "txt") (base-directory old-dist)))) (dolist (file (directory wild)) (delete-file file))))) (let ((reinstall-releases (installed-releases old-dist))) (remove-installed "systems") (remove-installed "releases") (delete-file-if-exists (relative-to old-dist "releases.txt")) (delete-file-if-exists (relative-to old-dist "systems.txt")) (delete-file-if-exists (relative-to old-dist "releases.cdb")) (delete-file-if-exists (relative-to old-dist "systems.cdb")) (replace-file (local-distinfo-file new-dist) (local-distinfo-file old-dist)) (setf new-dist (find-dist (name new-dist))) (dolist (old-release reinstall-releases) (let* ((name (name old-release)) (new-release (find-release-in-dist name new-dist))) (if new-release (ensure-installed new-release) (warn "~S is not available in ~A" name new-dist))))))) (defun install-dist (url &key (prompt t) replace) (block nil (setf url (url url)) (let ((temp-file (qmerge "tmp/install-dist-distinfo.txt"))) (ensure-directories-exist temp-file) (delete-file-if-exists temp-file) (fetch url temp-file) (let* ((new-dist (make-dist-from-file temp-file)) (old-dist (find-dist (name new-dist)))) (when old-dist (if replace (uninstall old-dist) (restart-case (error "A dist named ~S is already installed." (name new-dist)) (replace () :report "Replace installed dist with new dist" (uninstall old-dist))))) (format t "Installing dist ~S version ~S.~%" (name new-dist) (version new-dist)) (when (or (not prompt) (press-enter-to-continue)) (ensure-directories-exist (base-directory new-dist)) (copy-file temp-file (relative-to new-dist "distinfo.txt")) (ensure-release-index-file new-dist) (ensure-system-index-file new-dist) (enable new-dist) (setf (preference new-dist) (get-universal-time)) (when old-dist (clear-dist-systems old-dist)) (clear-dist-systems new-dist) new-dist))))) quicklisp/dist.lisp000066400000000000000000001130271401210150300147050ustar00rootroot00000000000000;;;; dist.lisp (in-package #:ql-dist) ;;; Generic functions (defgeneric dist (object) (:documentation "Return the dist of OBJECT.")) (defgeneric available-versions (object) (:documentation "Return a list of version information for OBJECT.")) (defgeneric system-index-url (object) (:documentation "Return the URL for the system index of OBJECT.")) (defgeneric release-index-url (object) (:documentation "Return the URL for the release index of OBJECT.")) (defgeneric available-versions-url (object) (:documentation "Return the URL for the available versions data file of OBJECT.")) (defgeneric release (object) (:documentation "Return the release of OBJECT.")) (defgeneric system (object) (:documentation "Return the system of OBJECT.")) (defgeneric name (object) (:documentation "Return the name of OBJECT.")) (defgeneric find-system (name) (:documentation "Return a system with the given NAME, or NIL if no system is found. If multiple systems have the same name, the one with the highest preference is returned.")) (defgeneric find-release (name) (:documentation "Return a release with the given NAME, or NIL if no system is found. If multiple releases have the same name, the one with the highest preference is returned.")) (defgeneric find-systems-named (name) (:documentation "Return a list of all systems in all enabled dists with the given NAME, sorted by preference.")) (defgeneric find-releases-named (name) (:documentation "Return a list of all releases in all enabled dists with the given NAME, sorted by preference.")) (defgeneric base-directory (object) (:documentation "Return the base directory pathname of OBJECT.") (:method ((object pathname)) (merge-pathnames object))) (defgeneric relative-to (object pathname) (:documentation "Merge PATHNAME with the base-directory of OBJECT.") (:method (object pathname) (merge-pathnames pathname (base-directory object)))) (defgeneric enabledp (object) (:documentation "Return true if OBJECT is enabled.")) (defgeneric enable (object) (:documentation "Enable OBJECT.")) (defgeneric disable (object) (:documentation "Disable OBJECT.")) (defgeneric installedp (object) (:documentation "Return true if OBJECT is installed.")) (defgeneric install (object) (:documentation "Install OBJECT.")) (defgeneric ensure-installed (object) (:documentation "Ensure that OBJECT is installed.") (:method (object) (unless (installedp object) (install object)) object)) (defgeneric uninstall (object) (:documentation "Uninstall OBJECT.")) (defgeneric metadata-name (object) (:documentation "The metadata-name of an object is used to form the pathname for a few different object metadata files.")) (defgeneric install-metadata-file (object) (:documentation "The pathname to a file describing the installation status of OBJECT.")) (defgeneric subscription-inhibition-file (object) (:documentation "The file whose presence indicates the inhibited subscription status of OBJECT.") (:method (object) (relative-to object "subscription-inhibited.txt"))) (defgeneric inhibit-subscription (object) (:documentation "Inhibit subscription for OBJECT.") (:method (object) (ensure-file-exists (subscription-inhibition-file object)))) (defgeneric uninhibit-subscription (object) (:documentation "Remove inhibition of subscription for OBJECT.") (:method (object) (delete-file-if-exists (subscription-inhibition-file object)))) (defgeneric subscription-inhibited-p (object) (:documentation "Return T if subscription to OBJECT is inhibited.") (:method (object) (not (not (probe-file (subscription-inhibition-file object)))))) (define-condition subscription-unavailable (error) ((object :initarg :object :reader subscription-unavailable-object))) (defgeneric subscribedp (object) (:documentation "Return true if OBJECT is subscribed to updates.")) (defgeneric subscribe (object) (:documentation "Subscribe to updates of OBJECT, if possible. If no updates are available, a condition of type SUBSCRIPTION-UNAVAILABLE is raised.") (:method (object) (uninhibit-subscription object) (unless (subscribedp object) (error 'subscription-unavailable :object object)) t)) (defgeneric unsubscribe (object) (:documentation "Unsubscribe from updates to OBJECT.") (:method (object) (inhibit-subscription object))) (defgeneric preference-parent (object) (:documentation "Return a value suitable for checking if OBJECT has no specific preference set.") (:method (object) (declare (ignore object)) nil)) (defgeneric preference-file (object) (:documentation "Return the file from which preference information is loaded for OBJECT.") (:method (object) (relative-to object "preference.txt"))) (defgeneric preference (object) (:documentation "Returns a value used when comparing multiple systems or releases with the same name. Objects with higher preference are returned by FIND-SYSTEM and FIND-RELEASE.") (:method ((object null)) 0) (:method (object) (with-open-file (stream (preference-file object) :if-does-not-exist nil) (if stream (values (parse-integer (read-line stream))) (preference (preference-parent object)))))) (defgeneric (setf preference) (preference object) (:documentation "Set the preference for OBJECT. Objects with higher preference are returned by FIND-SYSTEM and FIND-RELEASE.") (:method (preference object) (check-type preference integer) (let ((preference-file (preference-file object))) (ensure-directories-exist preference-file) (with-open-file (stream (preference-file object) :direction :output :if-exists :supersede) (format stream "~D" preference))) preference)) (defgeneric forget-preference (object) (:documentation "Remove specific preference information for OBJECT.") (:method (object) (delete-file-if-exists (preference-file object)))) (defgeneric short-description (object) (:documentation "Return a short string describing OBJECT.")) (defgeneric provided-releases (object) (:documentation "Return a list of releases provided by OBJECT.")) (defgeneric provided-systems (object) (:documentation "Return a list of systems provided by OBJECT.")) (defgeneric installed-releases (dist) (:documentation "Return a list of all releases installed for DIST.") (:method (dist) (remove-if-not #'installedp (provided-releases dist)))) (defgeneric installed-systems (dist) (:documentation "Return a list of all systems installed for DIST.") (:method (dist) (remove-if-not #'installedp (provided-systems dist)))) (defgeneric new-version-available-p (dist) (:documentation "Return true if a new version of DIST is available.")) (defgeneric find-system-in-dist (system-name dist) (:documentation "Return a system with the given NAME in DIST, or NIL if no system is found.")) (defgeneric find-release-in-dist (release-name dist) (:documentation "Return a release with the given NAME in DIST, or NIL if no release is found.")) (defgeneric ensure-system-index-file (dist) (:documentation "Return the pathname for the system index file of DIST, fetching it from a remote source first if necessary.")) (defgeneric ensure-system-cdb-file (dist) (:documentation "Return the pathname for the system cdb file of DIST, creating it if necessary.")) (defgeneric ensure-release-index-file (dist) (:documentation "Return the pathname for the release index file of DIST, fetching it from a remote source first if necessary.")) (defgeneric ensure-release-cdb-file (dist) (:documentation "Return the pathname for the release cdb file of DIST, creating it if necessary.")) (defgeneric initialize-release-index (dist) (:documentation "Initialize the release index of DIST.")) (defgeneric initialize-system-index (dist) (:documentation "Initialize the system index of DIST.")) (defgeneric local-archive-file (release) (:documentation "Return the pathname to where the archive file of RELEASE should be stored.")) (defgeneric ensure-local-archive-file (release) (:documentation "If the archive file for RELEASE is not available locally, fetch it and return the pathname to it.")) (defgeneric check-local-archive-file (release) (:documentation "Check the local archive file of RELEASE for validity, including size and signature checks. Signals errors in the case of invalid files.")) (defgeneric archive-url (release) (:documentation "Return the full URL for fetching the archive file of RELEASE.")) (defgeneric installed-asdf-system-file (object) (:documentation "Return the path to the installed ASDF system file for OBJECT, or NIL if there is no installed system file.")) (eval-when (:compile-toplevel :load-toplevel :execute) (defmacro destructure-line (lambda-list line &body body) `(destructuring-bind ,lambda-list (split-spaces ,line) ,@body)) (defun call-for-each-line (fun file) (with-open-file (stream file) (loop for line = (read-line stream nil) while line do (funcall fun line)))) (defmacro for-each-line ((line file) &body body) `(call-for-each-line (lambda (,line) ,@body) ,file))) (defun make-line-instance (line class &rest initargs) "Create an instance from words in an index file line. The last initarg collects all the trailing arguments, if any." (let* ((words (split-spaces line)) (args (mapcan #'list (butlast initargs) words)) (trailing (subseq words (1- (length initargs))))) (apply #'make-instance class (first (last initargs)) trailing args))) (defun ignorable-line (line) (labels ((blank-char-p (char) (member char '(#\Space #\Tab))) (blankp (line) (every #'blank-char-p line)) (ignorable (line) (or (zerop (length line)) (blankp line) (eql (char line 0) #\#)))) (ignorable line))) (defvar *initarg-case-converter* (cond ((string= :string "string") #'string-downcase) ((string= :string "STRING") #'string-upcase))) (defun config-file-initargs (file) (flet ((initarg-keyword (string) ;; A concession to mlisp (intern (funcall *initarg-case-converter* string) 'keyword))) (let ((initargs '())) (for-each-line (line file) (unless (ignorable-line line) (destructure-line (initarg value) line (let ((keyword (initarg-keyword (string-right-trim ":" initarg)))) (push value initargs) (push keyword initargs))))) initargs))) ;;; ;;; A few generic things ;;; (defmethod dist ((name symbol)) (dist (string name))) (defmethod dist ((name string)) (find-dist (string-downcase name))) (defmethod release ((name symbol)) (release (string name))) (defmethod release ((name string)) (find-release (string-downcase name))) (defmethod system ((name symbol)) (system (string name))) (defmethod system ((name string)) (find-system (string-downcase name))) ;;; ;;; Dists ;;; ;;; A dist is a set of releases. ;;; (defclass dist () ((base-directory :initarg :base-directory :accessor base-directory) (name :initarg :name :accessor name) (version :initarg :version :accessor version) (system-index-url :initarg :system-index-url :accessor system-index-url) (release-index-url :initarg :release-index-url :accessor release-index-url) (available-versions-url :initarg :available-versions-url :accessor available-versions-url) (archive-base-url :initarg :archive-base-url :accessor archive-base-url) (canonical-distinfo-url :initarg :canonical-distinfo-url :accessor canonical-distinfo-url) (distinfo-subscription-url :initarg :distinfo-subscription-url :accessor distinfo-subscription-url) (system-index :initarg :system-index :accessor system-index) (release-index :initarg :release-index :accessor release-index) (provided-systems :initarg :provided-systems :accessor provided-systems) (provided-releases :initarg :provided-releases :accessor provided-releases) (local-distinfo-file :initarg :local-distinfo-file :accessor local-distinfo-file)) (:default-initargs :name "unnamed" :version "unknown" :distinfo-subscription-url nil)) (defmethod short-description ((dist dist)) (format nil "~A ~A" (name dist) (version dist))) (defmethod print-object ((dist dist) stream) (print-unreadable-object (dist stream :type t) (write-string (short-description dist) stream))) (defun cdb-lookup (dist key cdb) (ql-cdb:lookup key (relative-to dist cdb))) (defmethod slot-unbound (class (dist dist) (slot (eql 'available-versions-url))) (declare (ignore class)) (setf (available-versions-url dist) (make-versions-url (distinfo-subscription-url dist)))) (defmethod ensure-system-index-file ((dist dist)) (let ((pathname (relative-to dist "systems.txt"))) (or (probe-file pathname) (nth-value 1 (fetch (system-index-url dist) pathname))))) (defmethod ensure-system-cdb-file ((dist dist)) (let* ((system-file (ensure-system-index-file dist)) (cdb-file (make-pathname :type "cdb" :defaults system-file))) (or (probe-file cdb-file) (ql-cdb:convert-index-file system-file :cdb-file cdb-file :index 2)))) (defmethod ensure-release-index-file ((dist dist)) (let ((pathname (relative-to dist "releases.txt"))) (or (probe-file pathname) (nth-value 1 (fetch (release-index-url dist) pathname))))) (defmethod ensure-release-cdb-file ((dist dist)) (let* ((release-file (ensure-release-index-file dist)) (cdb-file (make-pathname :type "cdb" :defaults release-file))) (or (probe-file cdb-file) (ql-cdb:convert-index-file release-file :cdb-file cdb-file :index 0)))) (defmethod slot-unbound (class (dist dist) (slot (eql 'provided-systems))) (declare (ignore class)) (initialize-system-index dist) (setf (slot-value dist 'provided-systems) (loop for system being each hash-value of (system-index dist) collect system))) (defmethod slot-unbound (class (dist dist) (slot (eql 'provided-releases))) (declare (ignore class)) (initialize-release-index dist) (setf (slot-value dist 'provided-releases) (loop for system being each hash-value of (release-index dist) collect system))) (defun dist-name-pathname (name) "Return the pathname that would be used for an installed dist with the given NAME." (qmerge (make-pathname :directory (list :relative "dists" name)))) (defmethod slot-unbound (class (dist dist) (slot (eql 'base-directory))) (declare (ignore class)) (setf (base-directory dist) (dist-name-pathname (name dist)))) (defun make-dist-from-file (file &key (class 'dist)) "Load dist info from FILE and use it to create a dist instance." (let ((initargs (config-file-initargs file))) (apply #'make-instance class :local-distinfo-file file :allow-other-keys t initargs))) (defmethod install-metadata-file ((dist dist)) (relative-to dist "distinfo.txt")) (defun find-dist (name) (find name (all-dists) :key #'name :test #'string=)) (defmethod enabledp ((dist dist)) (not (not (probe-file (relative-to dist "enabled.txt"))))) (defmethod enable ((dist dist)) (ensure-file-exists (relative-to dist "enabled.txt")) t) (defmethod disable ((dist dist)) (delete-file-if-exists (relative-to dist "enabled.txt")) t) (defmethod installedp ((dist dist)) (let ((installed (find-dist (name dist)))) (equalp (version installed) (version dist)))) (defmethod uninstall ((dist dist)) (when (installedp dist) (dolist (system (provided-systems dist)) (asdf:clear-system (name system))) (ql-impl-util:delete-directory-tree (base-directory dist)) t)) (defun make-release-from-line (line dist) (let ((release (make-line-instance line 'release :project-name :archive-url :archive-size :archive-md5 :archive-content-sha1 :prefix :system-files))) (setf (dist release) dist) (setf (archive-size release) (parse-integer (archive-size release))) release)) (defmethod find-release-in-dist (release-name (dist dist)) (let* ((index (release-index dist)) (release (gethash release-name index))) (or release (let ((line (cdb-lookup dist release-name (ensure-release-cdb-file dist)))) (when line (setf (gethash release-name index) (make-release-from-line line dist))))))) (defparameter *dist-enumeration-functions* '(standard-dist-enumeration-function) "ALL-DISTS calls each function in this list with no arguments, and appends the results into a list of dist objects, removing duplicates. Functions might be called just once for a batch of related operations; see WITH-CONSISTENT-DISTS.") (defun standard-dist-enumeration-function () "The default function used for producing a list of dist objects." (loop for file in (directory (qmerge "dists/*/distinfo.txt")) collect (make-dist-from-file file))) (defun all-dists () "Return a list of all known dists." (remove-duplicates (apply 'append (mapcar 'funcall *dist-enumeration-functions*)))) (defun enabled-dists () "Return a list of all known dists for which ENABLEDP returns true." (remove-if-not #'enabledp (all-dists))) (defmethod install-metadata-file (object) (relative-to (dist object) (make-pathname :directory (list :relative "installed" (metadata-name object)) :name (name object) :type "txt"))) (defclass preference-mixin () () (:documentation "Instances of this class have a special location for their preference files.")) (defgeneric filesystem-name (object) (:method (object) ;; This is to work around system names like "foo/bar". (let* ((name (name object)) (slash (position #\/ name))) (if slash (subseq name 0 slash) name)))) (defmethod preference-file ((object preference-mixin)) (relative-to (dist object) (make-pathname :directory (list :relative "preferences" (metadata-name object)) :name (filesystem-name object) :type "txt"))) (defmethod distinfo-subscription-url :around ((dist dist)) (unless (subscription-inhibited-p dist) (call-next-method))) (defmethod subscribedp ((dist dist)) (distinfo-subscription-url dist)) ;;; ;;; Releases ;;; (defclass release (preference-mixin) ((project-name :initarg :project-name :accessor name :accessor project-name) (dist :initarg :dist :accessor dist :reader preference-parent) (provided-systems :initarg :provided-systems :accessor provided-systems) (archive-url :initarg :archive-url :accessor archive-url) (archive-size :initarg :archive-size :accessor archive-size) (archive-md5 :initarg :archive-md5 :accessor archive-md5) (archive-content-sha1 :initarg :archive-content-sha1 :accessor archive-content-sha1) (prefix :initarg :prefix :accessor prefix :reader short-description) (system-files :initarg :system-files :accessor system-files) (metadata-name :initarg :metadata-name :accessor metadata-name)) (:default-initargs :metadata-name "releases") (:documentation "Instances of this class represent a snapshot of a project at some point in time, which might be from version control, or from an official release, or from some other source.")) (defmethod print-object ((release release) stream) (print-unreadable-object (release stream :type t) (format stream "~A / ~A" (short-description release) (short-description (dist release))))) (define-condition invalid-local-archive (error) ((release :initarg :release :reader invalid-local-archive-release) (file :initarg :file :reader invalid-local-archive-file)) (:report (lambda (condition stream) (format stream "The archive file ~S for release ~S is invalid" (file-namestring (invalid-local-archive-file condition)) (name (invalid-local-archive-release condition)))))) (define-condition missing-local-archive (invalid-local-archive) () (:report (lambda (condition stream) (format stream "The archive file ~S for release ~S is missing" (file-namestring (invalid-local-archive-file condition)) (name (invalid-local-archive-release condition)))))) (define-condition badly-sized-local-archive (invalid-local-archive) ((expected-size :initarg :expected-size :reader badly-sized-local-archive-expected-size) (actual-size :initarg :actual-size :reader badly-sized-local-archive-actual-size)) (:report (lambda (condition stream) (format stream "The archive file ~S for ~S is the wrong size: ~ expected ~:D, got ~:D" (file-namestring (invalid-local-archive-file condition)) (name (invalid-local-archive-release condition)) (badly-sized-local-archive-expected-size condition) (badly-sized-local-archive-actual-size condition))))) (defmethod check-local-archive-file ((release release)) (let ((file (local-archive-file release))) (unless (probe-file file) (error 'missing-local-archive :file file :release release)) (let ((actual-size (file-size file)) (expected-size (archive-size release))) (unless (= actual-size expected-size) (error 'badly-sized-local-archive :file file :release release :actual-size actual-size :expected-size expected-size))))) (defmethod local-archive-file ((release release)) (relative-to (dist release) (make-pathname :directory '(:relative "archives") :defaults (file-namestring (path (url (archive-url release))))))) (defmethod ensure-local-archive-file ((release release)) (let ((pathname (local-archive-file release))) (tagbody :retry (or (probe-file pathname) (progn (ensure-directories-exist pathname) (fetch (archive-url release) pathname))) (restart-case (check-local-archive-file release) (delete-and-retry (&optional v) :report "Delete the archive file and fetch it again" (declare (ignore v)) (delete-file pathname) (go :retry)))) pathname)) (defmethod base-directory ((release release)) (relative-to (dist release) (make-pathname :directory (list :relative "software" (prefix release))))) (defmethod installedp ((release release)) (and (probe-file (install-metadata-file release)) (every #'installedp (provided-systems release)))) (defmethod install ((release release)) (let ((archive (ensure-local-archive-file release)) (output (relative-to (dist release) (make-pathname :directory (list :relative "software")))) (tracking (install-metadata-file release))) (with-temporary-file (tar "release-install.tar") (ensure-directories-exist tar) (ensure-directories-exist output) (ensure-directories-exist tracking) (gunzip archive tar) (unpack-tarball tar :directory output)) (ensure-directories-exist tracking) (with-open-file (stream tracking :direction :output :if-exists :supersede) (write-line (qenough (base-directory release)) stream)) (let ((provided (provided-systems release)) (dist (dist release))) (dolist (file (system-files release)) (let ((system (find-system-in-dist (pathname-name file) dist))) (unless (member system provided) (error "FIND-SYSTEM-IN-DIST returned ~A but I expected one of ~A" system provided)) (let ((system-tracking (install-metadata-file system)) (system-file (merge-pathnames file (base-directory release)))) (ensure-directories-exist system-tracking) (unless (probe-file system-file) (error "Release claims to have ~A, but I can't find it" system-file)) (with-open-file (stream system-tracking :direction :output :if-exists :supersede) (write-line (qenough system-file) stream)))))) release)) (defmethod uninstall ((release release)) (when (installedp release) (dolist (system (installed-systems release)) (asdf:clear-system (name system)) (delete-file (install-metadata-file system))) (delete-file (install-metadata-file release)) (delete-file (local-archive-file release)) (ql-impl-util:delete-directory-tree (base-directory release)) t)) (defun call-for-each-index-entry (file fun) (labels ((blank-char-p (char) (member char '(#\Space #\Tab))) (blankp (line) (every #'blank-char-p line)) (ignorable (line) (or (zerop (length line)) (blankp line) (eql (char line 0) #\#)))) (with-open-file (stream file) (loop for line = (read-line stream nil) while line do (unless (ignorable line) (funcall fun line)))))) (defmethod slot-unbound (class (dist dist) (slot (eql 'release-index))) (declare (ignore class)) (setf (slot-value dist 'release-index) (make-hash-table :test 'equal))) ;;; ;;; Systems ;;; ;;; A "system" in the defsystem sense. ;;; (defclass system (preference-mixin) ((name :initarg :name :accessor name :reader short-description) (system-file-name :initarg :system-file-name :accessor system-file-name) (release :initarg :release :accessor release :reader preference-parent) (dist :initarg :dist :accessor dist) (required-systems :initarg :required-systems :accessor required-systems) (metadata-name :initarg :metadata-name :accessor metadata-name)) (:default-initargs :metadata-name "systems")) (defmethod print-object ((system system) stream) (print-unreadable-object (system stream :type t) (format stream "~A / ~A / ~A" (short-description system) (short-description (release system)) (short-description (dist system))))) (defmethod provided-systems ((system system)) (list system)) (defmethod initialize-release-index ((dist dist)) (let ((releases (ensure-release-index-file dist)) (index (release-index dist))) (call-for-each-index-entry releases (lambda (line) (let ((instance (make-line-instance line 'release :project-name :archive-url :archive-size :archive-md5 :archive-content-sha1 :prefix :system-files))) ;; Don't clobber anything previously loaded via CDB (unless (gethash (project-name instance) index) (setf (dist instance) dist) (setf (archive-size instance) (parse-integer (archive-size instance))) (setf (gethash (project-name instance) index) instance))))) (setf (release-index dist) index))) (defmethod initialize-system-index ((dist dist)) (initialize-release-index dist) (let ((systems (ensure-system-index-file dist)) (index (system-index dist))) (call-for-each-index-entry systems (lambda (line) (let ((instance (make-line-instance line 'system :release :system-file-name :name :required-systems))) ;; Don't clobber anything previously loaded via CDB (unless (gethash (name instance) index) (let ((release (find-release-in-dist (release instance) dist))) (setf (release instance) release) (if (slot-boundp release 'provided-systems) (pushnew instance (provided-systems release)) (setf (provided-systems release) (list instance)))) (setf (dist instance) dist) (setf (gethash (name instance) index) instance))))) (setf (system-index dist) index))) (defmethod slot-unbound (class (release release) (slot (eql 'provided-systems))) (declare (ignore class)) ;; FIXME: This isn't right, since the system index has systems that ;; don't match the defining system file name. (setf (slot-value release 'provided-systems) (mapcar (lambda (system-file) (find-system-in-dist (pathname-name system-file) (dist release))) (system-files release)))) (defmethod slot-unbound (class (dist dist) (slot (eql 'system-index))) (declare (ignore class)) (setf (slot-value dist 'system-index) (make-hash-table :test 'equal))) (defun make-system-from-line (line dist) (let ((system (make-line-instance line 'system :release :system-file-name :name :required-systems))) (setf (dist system) dist) (setf (release system) (find-release-in-dist (release system) dist)) system)) (defmethod find-system-in-dist (system-name (dist dist)) (let* ((index (system-index dist)) (system (gethash system-name index))) (or system (let ((line (cdb-lookup dist system-name (ensure-system-cdb-file dist)))) (when line (setf (gethash system-name index) (make-system-from-line line dist))))))) (defmethod preference ((system system)) (if (probe-file (preference-file system)) (call-next-method) (preference (release system)))) (defun thing-name-designator (designator) "Convert DESIGNATOR to a string naming a thing. Strings are used as-is, symbols are converted to their downcased symbol-name." (typecase designator (string designator) (symbol (string-downcase designator)) (t (error "~S is not a valid designator for a system or release" designator)))) (defun find-thing-named (find-fun name) (setf name (thing-name-designator name)) (let ((result '())) (dolist (dist (enabled-dists) (sort result #'> :key #'preference)) (let ((thing (funcall find-fun name dist))) (when thing (push thing result)))))) (defmethod find-systems-named (name) (find-thing-named #'find-system-in-dist name)) (defmethod find-releases-named (name) (find-thing-named #'find-release-in-dist name)) (defmethod find-system (name) (first (find-systems-named name))) (defmethod find-release (name) (first (find-releases-named name))) (defmethod install ((system system)) (ensure-installed (release system))) (defmethod install-metadata-file ((system system)) (relative-to (dist system) (make-pathname :name (system-file-name system) :type "txt" :directory '(:relative "installed" "systems")))) (defmethod installed-asdf-system-file ((system system)) (let ((metadata-file (install-metadata-file system))) (when (probe-file metadata-file) (with-open-file (stream metadata-file) (let* ((relative (read-line stream)) (full (qmerge relative))) (when (probe-file full) full)))))) (defmethod installedp ((system system)) (installed-asdf-system-file system)) (defmethod uninstall ((system system)) (uninstall (release system))) (defun find-asdf-system-file (name) "Return the ASDF system file in which the system named NAME is defined." (let ((system (find-system name))) (when system (installed-asdf-system-file system)))) (defun system-definition-searcher (name) "Like FIND-ASDF-SYSTEM-FILE, but this function can be used in ASDF:*SYSTEM-DEFINITION-SEARCH-FUNCTIONS*; it will only return system file names if they match NAME." (let ((system-file (find-asdf-system-file name))) (when (and system-file (string= (pathname-name system-file) name)) system-file))) (defun call-with-consistent-dists (fun) "Take a snapshot of the available dists and return the same list consistently each time ALL-DISTS is called in the dynamic scope of FUN." (let* ((all-dists (all-dists)) (*dist-enumeration-functions* (list (constantly all-dists)))) (funcall fun))) (defmacro with-consistent-dists (&body body) "See CALL-WITH-CONSISTENT-DISTS." `(call-with-consistent-dists (lambda () ,@body))) (defgeneric dependency-tree (system) (:method ((symbol symbol)) (dependency-tree (string-downcase symbol))) (:method ((string string)) (let ((system (find-system string))) (when system (dependency-tree system)))) (:method ((system system)) (with-consistent-dists (list* system (remove nil (mapcar 'dependency-tree (required-systems system))))))) (defmethod provided-systems ((object (eql t))) (let ((systems (loop for dist in (enabled-dists) appending (provided-systems dist)))) (sort systems #'string< :key #'name))) (defmethod provided-releases ((object (eql t))) (let ((releases (loop for dist in (enabled-dists) appending (provided-releases dist)))) (sort releases #'string< :key #'name))) (defgeneric system-apropos-list (term) (:method ((term symbol)) (system-apropos-list (symbol-name term))) (:method ((term string)) (setf term (string-downcase term)) (let ((result '())) (dolist (system (provided-systems t) (nreverse result)) (when (or (search term (name system)) (search term (name (release system)))) (push system result)))))) (defgeneric system-apropos (term) (:method (term) (map nil (lambda (system) (format t "~A~%" system)) (system-apropos-list term)) (values))) ;;; ;;; Clean up things ;;; (defgeneric clean (object) (:documentation "Remove any unneeded files or directories related to OBJECT.")) (defmethod clean ((dist dist)) (let* ((releases (provided-releases dist)) (known-archives (mapcar 'local-archive-file releases)) (known-directories (mapcar 'base-directory releases)) (present-archives (mapcar 'truename (directory-entries (relative-to dist "archives/")))) (present-directories (mapcar 'truename (directory-entries (relative-to dist "software/")))) (garbage-archives (set-difference present-archives known-archives :test 'equalp)) (garbage-directories ;; Use the namestring here on the theory that pathnames with ;; equalp namestrings are sufficiently the same. On ;; LispWorks, for example, identical namestrings can still ;; differ in :name, :type, and more. (set-difference present-directories known-directories :test 'equalp :key 'namestring))) (map nil 'delete-file garbage-archives) (map nil 'delete-directory-tree garbage-directories))) ;;; ;;; Available versions ;;; (defmethod available-versions ((dist dist)) (let ((temp (qmerge "tmp/dist-versions.txt")) (versions '()) (url (available-versions-url dist))) (when url (ensure-directories-exist temp) (delete-file-if-exists temp) (handler-case (fetch url temp) (unexpected-http-status () (return-from available-versions nil))) (with-open-file (stream temp) (loop for line = (read-line stream nil) while line do (destructuring-bind (version url) (split-spaces line) (setf versions (acons version url versions))))) versions))) ;;; ;;; User interface bits to re-export from QL ;;; (define-condition unknown-dist (error) ((name :initarg :name :reader unknown-dist-name)) (:report (lambda (condition stream) (format stream "No dist known by that name -- ~S" (unknown-dist-name condition))))) (defun find-dist-or-lose (name) (let ((dist (find-dist name))) (or dist (error 'unknown-dist :name name)))) (defun dist-url (name) (canonical-distinfo-url (find-dist-or-lose name))) (defun dist-version (name) (version (find-dist-or-lose name))) quicklisp/fetch-gzipped.lisp000066400000000000000000000015671401210150300165000ustar00rootroot00000000000000;;;; fetch-gzipped.lisp (in-package #:quicklisp-client) (defun gzipped-url (url) (check-type url string) (concatenate 'string url ".gz")) (defun fetch-gzipped-version (url file &key quietly) (let ((gzipped (gzipped-url url)) (gzipped-temp (merge-pathnames "gzipped.tmp" file))) (fetch gzipped gzipped-temp :quietly quietly) (gunzip gzipped-temp file) (delete-file-if-exists gzipped-temp) (probe-file file))) (defun url-not-suitable-error-p (condition) (<= 400 (unexpected-http-status-code condition) 499)) (defun maybe-fetch-gzipped (url file &key quietly) (handler-case (fetch-gzipped-version url file :quietly quietly) (unexpected-http-status (condition) (cond ((url-not-suitable-error-p condition) (fetch url file :quietly quietly) (probe-file file)) (t (error condition)))))) quicklisp/http.lisp000066400000000000000000000661141401210150300147250ustar00rootroot00000000000000;;; ;;; A simple HTTP client ;;; (in-package #:ql-http) ;;; Octet data (deftype octet () '(unsigned-byte 8)) (defun make-octet-vector (size) (make-array size :element-type 'octet :initial-element 0)) (defun octet-vector (&rest octets) (make-array (length octets) :element-type 'octet :initial-contents octets)) ;;; ASCII characters as integers (defun acode (char) (cond ((eql char :cr) 13) ((eql char :lf) 10) (t (let ((code (char-code char))) (if (<= 0 code 127) code (error "Character ~S is not in the ASCII character set" char)))))) (defvar *whitespace* (list (acode #\Space) (acode #\Tab) (acode :cr) (acode :lf))) (defun whitep (code) (member code *whitespace*)) (defun ascii-vector (string) (let ((vector (make-octet-vector (length string)))) (loop for char across string for code = (char-code char) for i from 0 if (< 127 code) do (error "Invalid character for ASCII -- ~A" char) else do (setf (aref vector i) code)) vector)) (defun ascii-subseq (vector start end) "Return a subseq of octet-specialized VECTOR as a string." (let ((string (make-string (- end start)))) (loop for i from 0 for j from start below end do (setf (char string i) (code-char (aref vector j)))) string)) (defun ascii-downcase (code) (if (<= 65 code 90) (+ code 32) code)) (defun ascii-equal (a b) (eql (ascii-downcase a) (ascii-downcase b))) (defmacro acase (value &body cases) (flet ((convert-case-keys (keys) (mapcar (lambda (key) (etypecase key (integer key) (character (char-code key)) (symbol (ecase key (:cr 13) (:lf 10) ((t) t))))) (if (consp keys) keys (list keys))))) `(case ,value ,@(mapcar (lambda (case) (destructuring-bind (keys &rest body) case `(,(if (eql keys t) t (convert-case-keys keys)) ,@body))) cases)))) ;;; Pattern matching (for finding headers) (defclass matcher () ((pattern :initarg :pattern :reader pattern) (pos :initform 0 :accessor match-pos) (matchedp :initform nil :accessor matchedp))) (defun reset-match (matcher) (setf (match-pos matcher) 0 (matchedp matcher) nil)) (define-condition match-failure (error) ()) (defun match (matcher input &key (start 0) end error) (let ((i start) (end (or end (length input))) (match-end (length (pattern matcher)))) (with-slots (pattern pos) matcher (loop (cond ((= pos match-end) (let ((match-start (- i pos))) (setf pos 0) (setf (matchedp matcher) t) (return (values match-start (+ match-start match-end))))) ((= i end) (return nil)) ((= (aref pattern pos) (aref input i)) (incf i) (incf pos)) (t (if error (error 'match-failure) (if (zerop pos) (incf i) (setf pos 0))))))))) (defun ascii-matcher (string) (make-instance 'matcher :pattern (ascii-vector string))) (defun octet-matcher (&rest octets) (make-instance 'matcher :pattern (apply 'octet-vector octets))) (defun acode-matcher (&rest codes) (make-instance 'matcher :pattern (make-array (length codes) :element-type 'octet :initial-contents (mapcar 'acode codes)))) ;;; "Connection Buffers" are a kind of callback-driven, ;;; pattern-matching chunky stream. Callbacks can be called for a ;;; certain number of octets or until one or more patterns are seen in ;;; the input. cbufs automatically refill themselves from a ;;; connection as needed. (defvar *cbuf-buffer-size* 8192) (define-condition end-of-data (error) ()) (defclass cbuf () ((data :initarg :data :accessor data) (connection :initarg :connection :accessor connection) (start :initarg :start :accessor start) (end :initarg :end :accessor end) (eofp :initarg :eofp :accessor eofp)) (:default-initargs :data (make-octet-vector *cbuf-buffer-size*) :connection nil :start 0 :end 0 :eofp nil) (:documentation "A CBUF is a connection buffer that keeps track of incoming data from a connection. Several functions make it easy to treat a CBUF as a kind of chunky, callback-driven stream.")) (define-condition cbuf-progress () ((size :initarg :size :accessor cbuf-progress-size :initform 0))) (defun call-processor (fun cbuf start end) (signal 'cbuf-progress :size (- end start)) (funcall fun (data cbuf) start end)) (defun make-cbuf (connection) (make-instance 'cbuf :connection connection)) (defun make-stream-writer (stream) "Create a callback for writing data to STREAM." (lambda (data start end) (write-sequence data stream :start start :end end))) (defgeneric size (cbuf) (:method ((cbuf cbuf)) (- (end cbuf) (start cbuf)))) (defgeneric emptyp (cbuf) (:method ((cbuf cbuf)) (zerop (size cbuf)))) (defgeneric refill (cbuf) (:method ((cbuf cbuf)) (when (eofp cbuf) (error 'end-of-data)) (setf (start cbuf) 0) (setf (end cbuf) (read-octets (data cbuf) (connection cbuf))) (cond ((emptyp cbuf) (setf (eofp cbuf) t) (error 'end-of-data)) (t (size cbuf))))) (defun process-all (fun cbuf) (unless (emptyp cbuf) (call-processor fun cbuf (start cbuf) (end cbuf)))) (defun multi-cmatch (matchers cbuf) (let (start end) (dolist (matcher matchers (values start end)) (multiple-value-bind (s e) (match matcher (data cbuf) :start (start cbuf) :end (end cbuf)) (when (and s (or (null start) (< s start))) (setf start s end e)))))) (defun cmatch (matcher cbuf) (if (consp matcher) (multi-cmatch matcher cbuf) (match matcher (data cbuf) :start (start cbuf) :end (end cbuf)))) (defun call-until-end (fun cbuf) (handler-case (loop (process-all fun cbuf) (refill cbuf)) (end-of-data () (return-from call-until-end)))) (defun show-cbuf (context cbuf) (format t "cbuf: ~A ~D - ~D~%" context (start cbuf) (end cbuf))) (defun call-for-n-octets (n fun cbuf) (let ((remaining n)) (loop (when (<= remaining (size cbuf)) (let ((end (+ (start cbuf) remaining))) (call-processor fun cbuf (start cbuf) end) (setf (start cbuf) end) (return))) (process-all fun cbuf) (decf remaining (size cbuf)) (refill cbuf)))) (defun call-until-matching (matcher fun cbuf) (loop (multiple-value-bind (start end) (cmatch matcher cbuf) (when start (call-processor fun cbuf (start cbuf) end) (setf (start cbuf) end) (return))) (process-all fun cbuf) (refill cbuf))) (defun ignore-data (data start end) (declare (ignore data start end))) (defun skip-until-matching (matcher cbuf) (call-until-matching matcher 'ignore-data cbuf)) ;;; Creating HTTP requests as octet buffers (defclass octet-sink () ((storage :initarg :storage :accessor storage)) (:default-initargs :storage (make-array 1024 :element-type 'octet :fill-pointer 0 :adjustable t)) (:documentation "A simple stream-like target for collecting octets.")) (defun add-octet (octet sink) (vector-push-extend octet (storage sink))) (defun add-octets (octets sink &key (start 0) end) (setf end (or end (length octets))) (loop for i from start below end do (add-octet (aref octets i) sink))) (defun add-string (string sink) (loop for char across string for code = (char-code char) do (add-octet code sink))) (defun add-strings (sink &rest strings) (mapc (lambda (string) (add-string string sink)) strings)) (defun add-newline (sink) (add-octet 13 sink) (add-octet 10 sink)) (defun sink-buffer (sink) (subseq (storage sink) 0)) (defvar *proxy-url* (config-value "proxy-url")) (defun full-proxy-path (host port path) (format nil "~:[http~;https~]://~A~:[:~D~;~*~]~A" (eql port 443) host (or (null port) (eql port 80) (eql port 443)) port path)) (defun user-agent-string () "Return a string suitable for using as the User-Agent value in HTTP requests. Includes Quicklisp version and CL implementation and version information." (labels ((requires-encoding (char) (not (or (alphanumericp char) (member char '(#\. #\- #\_))))) (encode (string) (substitute-if #\_ #'requires-encoding string)) (version-string (string) (if (string-equal string nil) "unknown" (let* ((length (length string)) (start (or (position-if #'digit-char-p string) 0)) (space (or (position #\Space string :start start) length)) (limit (min space length (+ start 24)))) (encode (subseq string start limit)))))) ;; FIXME: Be more configurable, and take/set the version from ;; somewhere else. (format nil "quicklisp-client/~A ~A/~A" ql-info:*version* (encode (lisp-implementation-type)) (version-string (lisp-implementation-version))))) (defun make-request-buffer (host port path &key (method "GET")) "Return an octet vector suitable for sending as an HTTP 1.1 request." (setf method (string method)) (when *proxy-url* (setf path (full-proxy-path host port path))) (let ((sink (make-instance 'octet-sink))) (flet ((add-line (&rest strings) (apply #'add-strings sink strings) (add-newline sink))) (add-line method " " path " HTTP/1.1") (add-line "Host: " host (if (integerp port) (format nil ":~D" port) "")) (add-line "Connection: close") (add-line "User-Agent: " (user-agent-string)) (add-newline sink) (sink-buffer sink)))) (defun sink-until-matching (matcher cbuf) (let ((sink (make-instance 'octet-sink))) (call-until-matching matcher (lambda (buffer start end) (add-octets buffer sink :start start :end end)) cbuf) (sink-buffer sink))) ;;; HTTP headers (defclass header () ((data :initarg :data :accessor data) (status :initarg :status :accessor status) (name-starts :initarg :name-starts :accessor name-starts) (name-ends :initarg :name-ends :accessor name-ends) (value-starts :initarg :value-starts :accessor value-starts) (value-ends :initarg :value-ends :accessor value-ends))) (defmethod print-object ((header header) stream) (print-unreadable-object (header stream :type t) (prin1 (status header) stream))) (defun matches-at (pattern target pos) (= (mismatch pattern target :start2 pos) (length pattern))) (defun header-value-indexes (field-name header) (loop with data = (data header) with pattern = (ascii-vector (string-downcase field-name)) for start across (name-starts header) for i from 0 when (matches-at pattern data start) return (values (aref (value-starts header) i) (aref (value-ends header) i)))) (defun ascii-header-value (field-name header) (multiple-value-bind (start end) (header-value-indexes field-name header) (when start (ascii-subseq (data header) start end)))) (defun all-field-names (header) (map 'list (lambda (start end) (ascii-subseq (data header) start end)) (name-starts header) (name-ends header))) (defun headers-alist (header) (mapcar (lambda (name) (cons name (ascii-header-value name header))) (all-field-names header))) (defmethod describe-object :after ((header header) stream) (format stream "~&Decoded headers:~% ~S~%" (headers-alist header))) (defun content-length (header) (let ((field-value (ascii-header-value "content-length" header))) (when field-value (let ((value (ignore-errors (parse-integer field-value)))) (or value (error "Content-Length header field value is not a number -- ~A" field-value)))))) (defun chunkedp (header) (string= (ascii-header-value "transfer-encoding" header) "chunked")) (defun location (header) (ascii-header-value "location" header)) (defun status-code (vector) (let* ((space (position (acode #\Space) vector)) (c1 (- (aref vector (incf space)) 48)) (c2 (- (aref vector (incf space)) 48)) (c3 (- (aref vector (incf space)) 48))) (+ (* c1 100) (* c2 10) (* c3 1)))) (defun force-downcase-field-names (header) (loop with data = (data header) for start across (name-starts header) for end across (name-ends header) do (loop for i from start below end for code = (aref data i) do (setf (aref data i) (ascii-downcase code))))) (defun skip-white-forward (pos vector) (position-if-not 'whitep vector :start pos)) (defun skip-white-backward (pos vector) (let ((nonwhite (position-if-not 'whitep vector :end pos :from-end t))) (if nonwhite (1+ nonwhite) pos))) (defun contract-field-value-indexes (header) "Header field values exclude leading and trailing whitespace; adjust the indexes in the header accordingly." (loop with starts = (value-starts header) with ends = (value-ends header) with data = (data header) for i from 0 for start across starts for end across ends do (setf (aref starts i) (skip-white-forward start data)) (setf (aref ends i) (skip-white-backward end data)))) (defun next-line-pos (vector) (let ((pos 0)) (labels ((finish (&optional (i pos)) (return-from next-line-pos i)) (after-cr (code) (acase code (:lf (finish pos)) (t (finish (1- pos))))) (pending (code) (acase code (:cr #'after-cr) (:lf (finish pos)) (t #'pending)))) (let ((state #'pending)) (loop (setf state (funcall state (aref vector pos))) (incf pos)))))) (defun make-hvector () (make-array 16 :fill-pointer 0 :adjustable t)) (defun process-header (vector) "Create a HEADER instance from the octet data in VECTOR." (let* ((name-starts (make-hvector)) (name-ends (make-hvector)) (value-starts (make-hvector)) (value-ends (make-hvector)) (header (make-instance 'header :data vector :status 999 :name-starts name-starts :name-ends name-ends :value-starts value-starts :value-ends value-ends)) (mark nil) (pos (next-line-pos vector))) (unless pos (error "Unable to process HTTP header")) (setf (status header) (status-code vector)) (labels ((save (value vector) (vector-push-extend value vector)) (mark () (setf mark pos)) (clear-mark () (setf mark nil)) (finish () (if mark (save mark value-ends) (save pos value-ends)) (force-downcase-field-names header) (contract-field-value-indexes header) (return-from process-header header)) (in-new-line (code) (acase code ((#\Tab #\Space) (setf mark nil) #'in-value) (t (when mark (save mark value-ends)) (clear-mark) (save pos name-starts) (in-name code)))) (after-cr (code) (acase code (:lf #'in-new-line) (t (in-new-line code)))) (in-name (code) (acase code (#\: (save pos name-ends) (save (1+ pos) value-starts) #'in-value) ((:cr :lf) (finish)) ((#\Tab #\Space) (error "Unexpected whitespace in header field name")) (t (unless (<= 0 code 127) (error "Unexpected non-ASCII header field name")) #'in-name))) (in-value (code) (acase code (:lf (mark) #'in-new-line) (:cr (mark) #'after-cr) (t #'in-value)))) (let ((state #'in-new-line)) (loop (incf pos) (when (<= (length vector) pos) (error "No header found in response")) (setf state (funcall state (aref vector pos)))))))) ;;; HTTP URL parsing (defclass url () ((scheme :initarg :scheme :accessor scheme :initform nil) (hostname :initarg :hostname :accessor hostname :initform nil) (port :initarg :port :accessor port :initform nil) (path :initarg :path :accessor path :initform "/"))) (defun parse-urlstring (urlstring) (setf urlstring (string-trim " " urlstring)) (let* ((pos (position #\: urlstring)) (scheme (or (and pos (subseq urlstring 0 pos)) "http")) (pos (mismatch urlstring "://" :test 'char-equal :start1 pos)) (mark pos) (url (make-instance 'url))) (setf (scheme url) scheme) (labels ((save () (subseq urlstring mark pos)) (mark () (setf mark pos)) (finish () (return-from parse-urlstring url)) (hostname-char-p (char) (position char "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_." :test 'char-equal)) (at-start (char) (case char (#\/ (setf (port url) nil) (mark) #'in-path) (t #'in-host))) (in-host (char) (case char ((#\/ :end) (setf (hostname url) (save)) (mark) #'in-path) (#\: (setf (hostname url) (save)) (mark) #'in-port) (t (unless (hostname-char-p char) (error "~S is not a valid URL" urlstring)) #'in-host))) (in-port (char) (case char ((#\/ :end) (setf (port url) (parse-integer urlstring :start (1+ mark) :end pos)) (mark) #'in-path) (t (unless (digit-char-p char) (error "Bad port in URL ~S" urlstring)) #'in-port))) (in-path (char) (case char ((#\# :end) (setf (path url) (save)) (finish))) #'in-path)) (let ((state #'at-start)) (loop (when (<= (length urlstring) pos) (funcall state :end) (finish)) (setf state (funcall state (aref urlstring pos))) (incf pos)))))) (defun url (thing) (if (stringp thing) (parse-urlstring thing) thing)) (defgeneric request-buffer (method url) (:method (method url) (setf url (url url)) (make-request-buffer (hostname url) (or (port url) 80) (path url) :method method))) (defun urlstring (url) (format nil "~@[~A://~]~@[~A~]~@[:~D~]~A" (and (hostname url) (scheme url)) (hostname url) (port url) (path url))) (defmethod print-object ((url url) stream) (print-unreadable-object (url stream :type t) (prin1 (urlstring url) stream))) (defun merge-urls (url1 url2) (setf url1 (url url1)) (setf url2 (url url2)) (make-instance 'url :scheme (or (scheme url1) (scheme url2)) :hostname (or (hostname url1) (hostname url2)) :port (or (port url1) (port url2)) :path (or (path url1) (path url2)))) ;;; Requesting an URL and saving it to a file (defparameter *maximum-redirects* 10) (defvar *default-url-defaults* (url "http://src.quicklisp.org/")) (defun read-http-header (cbuf) (let ((header-data (sink-until-matching (list (acode-matcher :lf :lf) (acode-matcher :cr :cr) (acode-matcher :cr :lf :cr :lf)) cbuf))) (process-header header-data))) (defun read-chunk-header (cbuf) (let* ((header-data (sink-until-matching (acode-matcher :cr :lf) cbuf)) (end (or (position (acode :cr) header-data) (position (acode #\;) header-data)))) (values (parse-integer (ascii-subseq header-data 0 end) :radix 16)))) (defun save-chunk-response (stream cbuf) "For a chunked response, read all chunks and write them to STREAM." (let ((fun (make-stream-writer stream)) (matcher (acode-matcher :cr :lf))) (loop (let ((chunk-size (read-chunk-header cbuf))) (when (zerop chunk-size) (return)) (call-for-n-octets chunk-size fun cbuf) (skip-until-matching matcher cbuf))))) (defun save-response (file header cbuf &key (if-exists :rename-and-delete)) (with-open-file (stream file :direction :output :if-exists if-exists :element-type 'octet) (let ((content-length (content-length header))) (cond ((chunkedp header) (save-chunk-response stream cbuf)) (content-length (call-for-n-octets content-length (make-stream-writer stream) cbuf)) (t (call-until-end (make-stream-writer stream) cbuf)))))) (defun call-with-progress-bar (size fun) (let ((progress-bar (make-progress-bar size))) (start-display progress-bar) (flet ((update (condition) (update-progress progress-bar (cbuf-progress-size condition)))) (handler-bind ((cbuf-progress #'update)) (funcall fun))) (finish-display progress-bar))) (define-condition fetch-error (error) ()) (define-condition unexpected-http-status (fetch-error) ((status-code :initarg :status-code :reader unexpected-http-status-code) (url :initarg :url :reader unexpected-http-status-url)) (:report (lambda (condition stream) (format stream "Unexpected HTTP status for ~A: ~A" (unexpected-http-status-url condition) (unexpected-http-status-code condition))))) (define-condition too-many-redirects (fetch-error) ((url :initarg :url :reader too-many-redirects-url) (redirect-count :initarg :redirect-count :reader too-many-redirects-count)) (:report (lambda (condition stream) (format stream "Too many redirects (~:D) for ~A" (too-many-redirects-count condition) (too-many-redirects-url condition))))) (defvar *fetch-scheme-functions* '(("http" . http-fetch)) "assoc list to decide which scheme-function are called by FETCH function.") (defun fetch (url file &rest rest) "Request URL and write the body of the response to FILE." (let* ((url (merge-urls url *default-url-defaults*)) (call (cdr (assoc (scheme url) *fetch-scheme-functions* :test 'equal)))) (if call (apply call (urlstring url) file rest) (error "Unknown scheme ~S" url)))) (defun http-fetch (url file &key (follow-redirects t) quietly (if-exists :rename-and-delete) (maximum-redirects *maximum-redirects*)) "default scheme-function for http protocol." (setf url (merge-urls url *default-url-defaults*)) (setf file (merge-pathnames file)) (let ((redirect-count 0) (original-url url) (connect-url (or (url *proxy-url*) url)) (stream (if quietly (make-broadcast-stream) *trace-output*))) (loop (when (<= maximum-redirects redirect-count) (error 'too-many-redirects :url original-url :redirect-count redirect-count)) (with-connection (connection (hostname connect-url) (or (port connect-url) 80)) (let ((cbuf (make-instance 'cbuf :connection connection)) (request (request-buffer "GET" url))) (write-octets request connection) (let ((header (read-http-header cbuf))) (loop while (= (status header) 100) do (setf header (read-http-header cbuf))) (cond ((= (status header) 200) (let ((size (content-length header))) (format stream "~&; Fetching ~A~%" url) (if (and (numberp size) (plusp size)) (format stream "; ~$KB~%" (/ size 1024)) (format stream "; Unknown size~%")) (if quietly (save-response file header cbuf :if-exists if-exists) (call-with-progress-bar (content-length header) (lambda () (save-response file header cbuf :if-exists if-exists)))))) ((not (<= 300 (status header) 399)) (error 'unexpected-http-status :url url :status-code (status header)))) (if (and follow-redirects (<= 300 (status header) 399)) (let ((new-urlstring (ascii-header-value "location" header))) (when (not new-urlstring) (error "Redirect code ~D received, but no Location: header" (status header))) (incf redirect-count) (setf url (merge-urls new-urlstring url)) (format stream "~&; Redirecting to ~A~%" url)) (return (values header (and file (probe-file file))))))))))) quicklisp/impl-util.lisp000066400000000000000000000302641401210150300156570ustar00rootroot00000000000000;;;; impl-util.lisp (in-package #:ql-impl-util) (definterface call-with-quiet-compilation (fun) (:documentation "Call FUN with warnings, style-warnings, and other verbose messages suppressed.") (:implementation t (let ((*load-verbose* nil) (*compile-verbose* nil) (*load-print* nil) (*compile-print* nil)) (handler-bind ((warning #'muffle-warning)) (funcall fun))))) (defimplementation (call-with-quiet-compilation :for sbcl :qualifier :around) (fun) (declare (ignore fun)) (handler-bind ((ql-sbcl:compiler-note #'muffle-warning)) (call-next-method))) (defimplementation (call-with-quiet-compilation :for cmucl :qualifier :around) (fun) (declare (ignore fun)) (let ((ql-cmucl:*gc-verbose* nil)) (call-next-method))) (definterface rename-directory (from to) (:implementation t (rename-file from to) (truename to)) (:implementation cmucl (rename-file from (string-right-trim "/" (namestring to))) (truename to)) (:implementation clisp (ql-clisp:rename-directory from to) (truename to))) (definterface probe-directory (pathname) (:documentation "Return the truename of PATHNAME, if it exists and is a directory, or NIL otherwise.") (:implementation t (let ((directory (probe-file pathname))) (when directory ;; probe-file is specified to return the truename of the path, ;; but Allegro does not return the truename; truenamize it. (truename directory)))) (:implementation clisp (let ((directory (ql-clisp:probe-pathname pathname))) (when (and directory (ql-clisp:probe-directory directory)) directory)))) (definterface init-file-name () (:documentation "Return the init file name for the current implementation.") (:implementation allegro ".clinit.cl") (:implementation abcl ".abclrc") (:implementation ccl #+windows "ccl-init.lisp" #-windows ".ccl-init.lisp") (:implementation clasp ".clasprc") (:implementation clisp ".clisprc.lisp") (:implementation ecl ".eclrc") (:implementation mezzano "init.lisp") (:implementation mkcl ".mkclrc") (:implementation lispworks ".lispworks") (:implementation sbcl ".sbclrc") (:implementation cmucl ".cmucl-init.lisp") (:implementation scl ".scl-init.lisp") ) (defun init-file-name-for (&optional implementation-designator) (let* ((class-name (find-symbol (string-upcase implementation-designator) 'ql-impl)) (class (find-class class-name nil))) (when class (let ((*implementation* (make-instance class))) (init-file-name))))) (defun quicklisp-init-file-form () "Return a form suitable for describing the location of the quicklisp init file. If the file is available relative to the home directory, returns a form that merges with the home directory instead of specifying an absolute file." (let* ((init-file (ql-setup:qmerge "setup.lisp")) (enough (enough-namestring init-file (user-homedir-pathname)))) (cond ((equal (pathname enough) (pathname init-file)) ;; The init-file is somewhere outside of the home directory (pathname enough)) (t `(merge-pathnames ,enough (user-homedir-pathname)))))) (defun write-init-forms (stream &key (indentation 0)) (format stream "~%~v@T;;; The following lines added by ql:add-to-init-file:~%" indentation) (format stream "~v@T#-quicklisp~%" indentation) (let ((*print-case* :downcase)) (format stream "~v@T(let ((quicklisp-init ~S))~%" indentation (quicklisp-init-file-form))) (format stream "~v@T (when (probe-file quicklisp-init)~%" indentation) (format stream "~v@T (load quicklisp-init)))~%~%" indentation)) (defun suitable-lisp-init-file (implementation) "Return the name of IMPLEMENTATION's init file. If IMPLEMENTAION is a string or pathname, return its merged pathname instead." (typecase implementation ((or string pathname) (merge-pathnames implementation)) ((or null (eql t)) (init-file-name)) (t (init-file-name-for implementation)))) (defun add-to-init-file (&optional implementation-or-file) "Add forms to the Lisp implementation's init file that will load quicklisp at CL startup." (let ((init-file (suitable-lisp-init-file implementation-or-file))) (unless init-file (error "Don't know how to add to init file for your implementation.")) (setf init-file (merge-pathnames init-file (user-homedir-pathname))) (format *query-io* "~&I will append the following lines to ~S:~%" init-file) (write-init-forms *query-io* :indentation 2) (when (ql-util:press-enter-to-continue) (with-open-file (stream init-file :direction :output :if-does-not-exist :create :if-exists :append) (write-init-forms stream))) init-file)) ;;; ;;; Native namestrings. ;;; (definterface native-namestring (pathname) (:documentation "In Clozure CL, #\\.s in pathname-names are escaped in namestrings with #\\> on Windows and #\\\\ elsewhere. This can cause a problem when using CL:NAMESTRING to store pathname data that might be used by other implementations. NATIVE-NAMESTRING is intended to provide a namestring that can be parsed as a same-enough object on multiple implementations.") (:implementation t (namestring pathname)) (:implementation ccl (ql-ccl:native-translated-namestring pathname)) (:implementation sbcl (ql-sbcl:native-namestring pathname))) ;;; ;;; Directory write date ;;; (definterface directory-write-date (pathname) (:documentation "Return the write-date of the directory designated by PATHNAME as a universal time, like file-write-date.") (:implementation t (file-write-date pathname)) (:implementation clisp (nth-value 2 (ql-clisp:probe-pathname pathname)))) ;;; ;;; Deleting a directory tree ;;; (defvar *wild-entry* (make-pathname :name :wild :type :wild :version :wild)) (defvar *wild-relative* (make-pathname :directory '(:relative :wild))) (definterface directoryp (entry) (:documentation "Return true if ENTRY refers to a directory.") (:implementation t (not (or (pathname-name entry) (pathname-type entry)))) (:implementation allegro (ql-allegro:file-directory-p entry :follow-symbolic-links nil)) (:implementation lispworks (ql-lispworks:file-directory-p entry))) (definterface directory-entries (directory) (:documentation "Return all directory entries of DIRECTORY as a list, or NIL if there are no directory entries. Excludes the \".\" and \"..\" entries.") (:implementation allegro (directory directory #+allegro :directories-are-files #+allegro nil #+allegro :follow-symbolic-links #+allegro nil)) (:implementation abcl (directory (merge-pathnames *wild-entry* directory) #+abcl :resolve-symlinks #+abcl nil)) (:implementation ccl (directory (merge-pathnames *wild-entry* directory) #+ccl :directories #+ccl t #+ccl :follow-links #+ccl nil)) (:implementation clasp (nconc (directory (merge-pathnames *wild-entry* directory) #+clasp :resolve-symlinks #+clasp nil) (directory (merge-pathnames *wild-relative* directory) #+clasp :resolve-symlinks #+clasp nil))) (:implementation clisp ;; :full gives pathnames as well as truenames, BUT: it returns a ;; singleton pathname, not a list, on dead symlinks. (remove nil (mapcar (lambda (entry) (and (listp entry) (first entry))) (nconc (directory (merge-pathnames *wild-entry* directory) #+clisp :full #+clisp t #+clisp :if-does-not-exist #+clisp :keep) (directory (merge-pathnames *wild-relative* directory) #+clisp :full #+clisp t #+clisp :if-does-not-exist #+clisp :keep))))) (:implementation cmucl (directory (merge-pathnames *wild-entry* directory) #+cmucl :truenamep #+cmucl nil)) (:implementation scl (directory (merge-pathnames *wild-entry* directory) #+scl :truenamep #+scl nil)) (:implementation lispworks (directory (merge-pathnames *wild-entry* directory) #+lispworks :directories #+lispworks t #+lispworks :link-transparency #+lispworks nil)) (:implementation ecl (nconc (directory (merge-pathnames *wild-entry* directory) #+ecl :resolve-symlinks #+ecl nil) (directory (merge-pathnames *wild-relative* directory) #+ecl :resolve-symlinks #+ecl nil))) (:implementation mezzano (directory (merge-pathnames *wild-entry* directory))) (:implementation mkcl (setf directory (truename directory)) (nconc (directory (merge-pathnames *wild-entry* directory)) (directory (merge-pathnames *wild-relative* directory)))) (:implementation sbcl (directory (merge-pathnames *wild-entry* directory) #+sbcl :resolve-symlinks #+sbcl nil))) (defimplementation (directory-entries :qualifier :around) (directory) ;; Don't return any entries when called with a non-directory ;; argument (if (directoryp directory) (call-next-method) (warn "directory-entries - not a directory -- ~S" directory))) (definterface delete-directory (entry) (:documentation "Delete the directory ENTRY. Might signal an error if it is not an empty directory.") (:implementation t (delete-file entry)) (:implementation allegro (ql-allegro:delete-directory entry)) (:implementation ccl (ql-ccl:delete-directory entry)) (:implementation clasp (ql-clasp:rmdir entry)) (:implementation clisp (ql-clisp:delete-directory entry)) (:implementation cmucl (ql-cmucl:unix-rmdir (namestring entry))) (:implementation scl (ql-scl:unix-rmdir (ql-scl:unix-namestring entry))) (:implementation ecl (ql-ecl:rmdir entry)) (:implementation mkcl (ql-mkcl:rmdir entry)) (:implementation lispworks (ql-lispworks:delete-directory entry)) (:implementation sbcl (ql-sbcl:rmdir entry))) (defimplementation (delete-directory :qualifier :around) (directory) ;; Don't delete non-directories with delete-directory (if (directoryp directory) (call-next-method) (error "delete-directory - not a directory -- ~A" directory))) (definterface delete-directory-tree (pathname) (:documentation "Delete the directory tree rooted at PATHNAME.") (:implementation t (let ((directories-to-process (list (truename pathname))) (directories-to-delete '())) (loop (unless directories-to-process (return)) (let* ((current (pop directories-to-process)) (entries (directory-entries current))) (push current directories-to-delete) (dolist (entry entries) (if (directoryp entry) (push entry directories-to-process) (delete-file entry))))) (map nil 'delete-directory directories-to-delete))) (:implementation allegro (ql-allegro:delete-directory-and-files pathname)) (:implementation ccl (ql-ccl:delete-directory pathname))) (defimplementation (delete-directory-tree :qualifier :around) (pathname) (if (directoryp pathname) (call-next-method) (progn (warn "delete-directory-tree - not a directory, ~ deleting anyway -- ~s" pathname) (delete-file pathname)))) (defun map-directory-tree (directory fun) "Call FUN for every file in directory and all its subdirectories, recursively. Uses the truename of directory as a starting point. Does not follow symlinks, but, on some implementations, DOES include potentially dead symlinks." (let ((directories-to-process (list (truename directory)))) (loop (unless directories-to-process (return)) (let* ((current (pop directories-to-process)) (entries (directory-entries current))) (dolist (entry entries) (if (directoryp entry) (push entry directories-to-process) (funcall fun entry))))))) quicklisp/impl.lisp000066400000000000000000000234501401210150300147030ustar00rootroot00000000000000(in-package #:ql-impl) (eval-when (:compile-toplevel :load-toplevel :execute) (defun error-unimplemented (&rest args) (declare (ignore args)) (error "Not implemented"))) (defvar *interfaces* (make-hash-table) "A table of defined interfaces and their documentation.") (defun show-interfaces () "Display information about what interfaces are defined." (maphash (lambda (interface info) (destructuring-bind (arguments docstring) info (let ((*package* (find-package :keyword))) (format t "(~S ~:[()~;~:*~A~]~@[~% ~S~])~%" interface arguments docstring)))) *interfaces*)) (defmacro neuter-package (name) `(eval-when (:compile-toplevel :load-toplevel :execute) (let ((definition (fdefinition 'error-unimplemented))) (do-external-symbols (symbol ,(string name)) (unless (fboundp symbol) (setf (fdefinition symbol) definition)))))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun feature-expression-passes-p (expression) (cond ((keywordp expression) (member expression *features*)) ((consp expression) (case (first expression) (or (some 'feature-expression-passes-p (rest expression))) (and (every 'feature-expression-passes-p (rest expression))))) (t (error "Unrecognized feature expression -- ~S" expression))))) (defmacro define-implementation-package (feature package-name &rest options) (let* ((output-options '((:use) (:export #:lisp))) (prep (cdr (assoc :prep options))) (class-option (cdr (assoc :class options))) (class (first class-option)) (superclasses (rest class-option)) (import-options '()) (effectivep (feature-expression-passes-p feature))) (dolist (option options) (ecase (first option) ((:prep :class)) ((:import-from :import) (push option import-options)) ((:export :shadow :intern :documentation) (push option output-options)) ((:reexport-from) (push (cons :export (cddr option)) output-options) (push (cons :import-from (cdr option)) import-options)))) `(progn ,@(when effectivep `((eval-when (:compile-toplevel :load-toplevel :execute) ,@prep))) (defclass ,class ,superclasses ()) (defpackage ,package-name ,@output-options ,@(when effectivep import-options)) ,@(when effectivep `((setf *implementation* (make-instance ',class)))) ,@(unless effectivep `((neuter-package ,package-name)))))) (defmacro definterface (name lambda-list &body options) (let* ((doc-option (find :documentation options :key #'first)) (doc (second doc-option))) (setf (gethash name *interfaces*) (list lambda-list doc))) (let* ((forbidden (intersection lambda-list lambda-list-keywords)) (gf-options (remove :implementation options :key #'first)) (implementations (set-difference options gf-options)) (implementation-arg (copy-symbol '%implementation))) (when forbidden (error "~S not allowed in definterface lambda list" forbidden)) (flet ((method-option (class body) `(:method ((,implementation-arg ,class) ,@lambda-list) ,@body))) (let ((generic-name (intern (format nil "%~A" name)))) `(progn (defgeneric ,generic-name (lisp ,@lambda-list) ,@gf-options ,@(mapcan (lambda (implementation) (destructuring-bind (class &rest body) (rest implementation) (mapcar (lambda (class) (method-option class body)) (if (consp class) class (list class))))) implementations)) (defun ,name ,lambda-list (,generic-name *implementation* ,@lambda-list))))))) (defmacro defimplementation (name-and-options lambda-list &body body) (destructuring-bind (name &key (for t) qualifier) (if (consp name-and-options) name-and-options (list name-and-options)) (unless for (error "You must specify an implementation name.")) (let ((generic-name (find-symbol (format nil "%~A" name))) (implementation-arg (copy-symbol '%implementation))) (unless generic-name (error "~S does not name an implementation function" name)) `(defmethod ,generic-name ,@(when qualifier (list qualifier)) ,(list* `(,implementation-arg ,for) lambda-list) ,@body)))) ;;; Bootstrap implementations (defvar *implementation* nil) (defclass lisp () ()) ;;; Allegro Common Lisp (define-implementation-package :allegro #:ql-allegro (:documentation "Allegro Common Lisp - http://www.franz.com/products/allegrocl/") (:class allegro) (:reexport-from #:socket #:make-socket) (:reexport-from #:excl #:file-directory-p #:delete-directory #:delete-directory-and-files #:read-vector)) ;;; Armed Bear Common Lisp (define-implementation-package :abcl #:ql-abcl (:documentation "Armed Bear Common Lisp - http://common-lisp.net/project/armedbear/") (:class abcl) (:reexport-from #:ext #:make-socket #:get-socket-stream)) ;;; Clozure CL (define-implementation-package :ccl #:ql-ccl (:documentation "Clozure Common Lisp - http://www.clozure.com/clozurecl.html") (:class ccl) (:reexport-from #:ccl #:delete-directory #:make-socket #:native-translated-namestring)) ;;; CLASP (define-implementation-package :clasp #:ql-clasp (:documentation "CLASP - http://github.com/drmeister/clasp") (:class clasp) (:prep (require 'sockets)) (:intern #:host-network-address) (:reexport-from #:si #:rmdir #:file-kind) (:reexport-from #:sb-bsd-sockets #:get-host-by-name #:host-ent-address #:inet-socket #:socket-connect #:socket-make-stream)) ;;; GNU CLISP (define-implementation-package :clisp #:ql-clisp (:documentation "GNU CLISP - http://clisp.cons.org/") (:class clisp) (:reexport-from #:socket #:socket-connect) (:reexport-from #:ext #:delete-directory #:rename-directory #:probe-directory #:probe-pathname #:read-byte-sequence)) ;;; CMUCL (define-implementation-package :cmu #:ql-cmucl (:documentation "CMU Common Lisp - http://www.cons.org/cmucl/") (:class cmucl) (:reexport-from #:system #:make-fd-stream) (:reexport-from #:unix #:unix-rmdir) (:reexport-from #:extensions #:connect-to-inet-socket #:*gc-verbose*)) (defvar ql-cmucl:*gc-verbose*) ;;; Scieneer CL (define-implementation-package :scl #:ql-scl (:documentation "Scieneer Common Lisp - http://www.scieneer.com/scl/") (:class scl) (:reexport-from #:system #:make-fd-stream) (:reexport-from #:unix #:unix-rmdir) (:reexport-from #:extensions #:connect-to-inet-socket #:unix-namestring)) ;;; LispWorks (define-implementation-package :lispworks #:ql-lispworks (:documentation "LispWorks - http://www.lispworks.com/") (:class lispworks) (:prep (require "comm")) (:reexport-from #:lw #:file-directory-p #:delete-directory) (:reexport-from #:comm #:open-tcp-stream #:get-host-entry)) ;;; ECL (define-implementation-package :ecl #:ql-ecl (:documentation "ECL - http://ecls.sourceforge.net/") (:class ecl) (:prep (require 'sockets)) (:intern #:host-network-address) (:reexport-from #:si #:rmdir #:file-kind) (:reexport-from #:sb-bsd-sockets #:get-host-by-name #:host-ent-address #:inet-socket #:socket-connect #:socket-make-stream)) ;;; Mezzano (define-implementation-package :mezzano #:ql-mezzano (:documentation "Mezzano Lisp Operating System - https://github.com/froggey/Mezzano") (:class mezzano) (:reexport-from #:mezzano.network.tcp #:tcp-stream-connect)) ;;; MKCL (define-implementation-package :mkcl #:ql-mkcl (:documentation "ManKai Common Lisp - http://common-lisp.net/project/mkcl/") (:class mkcl) (:prep (require 'sockets)) (:intern #:host-network-address) (:reexport-from #:si #:rmdir #:file-kind) (:reexport-from #:sb-bsd-sockets #:get-host-by-name #:host-ent-address #:inet-socket #:socket-connect #:socket-make-stream)) ;;; SBCL (define-implementation-package :sbcl #:ql-sbcl (:class sbcl) (:documentation "Steel Bank Common Lisp - http://www.sbcl.org/") (:prep (require 'sb-posix) (require 'sb-bsd-sockets)) (:intern #:host-network-address) (:reexport-from #:sb-posix #:rmdir) (:reexport-from #:sb-ext #:compiler-note #:native-namestring) (:reexport-from #:sb-bsd-sockets #:get-host-by-name #:inet-socket #:host-ent-address #:socket-connect #:socket-make-stream)) quicklisp/local-projects.lisp000066400000000000000000000131121401210150300166550ustar00rootroot00000000000000;;;; local-projects.lisp ;;; ;;; Local project support. ;;; ;;; Local projects can be placed in /local-projects/. New ;;; entries in that directory are automatically scanned for system ;;; files for use with QL:QUICKLOAD. ;;; ;;; This works by keeping a cache of system file pathnames in ;;; /local-projects/system-index.txt. Whenever the ;;; timestamp on the local projects directory is newer than the ;;; timestamp on the system index file, the entire tree is re-scanned ;;; and cached. ;;; ;;; This will pick up system files that are created as a result of ;;; creating new project directory in /local-projects/, ;;; e.g. unpacking a tarball or zip file, checking out a project from ;;; version control, etc. It will NOT pick up a system file that is ;;; added sometime later in a subdirectory; for that, the ;;; REGISTER-LOCAL-PROJECTS function is needed to rebuild the system ;;; file index. ;;; ;;; In the event there are multiple systems of the same name in the ;;; directory tree, the one with the shortest pathname namestring is ;;; used. This is intended to ignore stuff like _darcs pristine ;;; directories. ;;; ;;; Work in progress! ;;; (in-package #:quicklisp-client) (defparameter *local-project-directories* (list (qmerge "local-projects/")) "The default local projects directory.") (defun system-index-file (pathname) "Return the system index file for the directory PATHNAME." (merge-pathnames "system-index.txt" pathname)) (defun matching-directory-files (directory fun) (let ((result '())) (map-directory-tree directory (lambda (file) (when (funcall fun file) (push file result)))) result)) (defun local-project-system-files (pathname) "Return a list of system files under PATHNAME." (let* ((files (matching-directory-files pathname (lambda (file) (equalp (pathname-type file) "asd"))))) (setf files (sort files #'string< :key #'namestring)) (stable-sort files #'< :key (lambda (file) (length (namestring file)))))) (defun make-system-index (pathname) "Create a system index file for all system files under PATHNAME. Current format is one native namestring per line." (setf pathname (truename pathname)) (with-open-file (stream (system-index-file pathname) :direction :output :if-exists :rename-and-delete) (dolist (system-file (local-project-system-files pathname)) (let ((system-path (enough-namestring system-file pathname))) (write-line (native-namestring system-path) stream))) (probe-file stream))) (defun find-valid-system-index (pathname) "Find a valid system index file for PATHNAME; one that both exists and has a newer timestamp than PATHNAME." (let* ((file (system-index-file pathname)) (probed (probe-file file))) (when (and probed (<= (directory-write-date pathname) (file-write-date probed))) probed))) (defun ensure-system-index (pathname) "Find or create a system index file for PATHNAME." (or (find-valid-system-index pathname) (make-system-index pathname))) (defun find-system-in-index (system index-file) "If any system pathname in INDEX-FILE has a pathname-name matching SYSTEM, return its full pathname." (with-open-file (stream index-file) (loop for namestring = (read-line stream nil) while namestring when (string= system (pathname-name namestring)) return (or (probe-file (merge-pathnames namestring index-file)) ;; If the indexed .asd file doesn't exist anymore ;; then regenerate the index and restart the search. (find-system-in-index system (make-system-index (directory-namestring index-file))))))) (defun local-projects-searcher (system-name) "This function is added to ASDF:*SYSTEM-DEFINITION-SEARCH-FUNCTIONS* to use the local project directory and cache to find systems." (dolist (directory *local-project-directories*) (when (probe-directory directory) (let ((system-index (ensure-system-index directory))) (when system-index (let ((system (find-system-in-index system-name system-index))) (when system (return system)))))))) (defun list-local-projects () "Return a list of pathnames to local project system files." (let ((result (make-array 16 :fill-pointer 0 :adjustable t)) (seen (make-hash-table :test 'equal))) (dolist (directory *local-project-directories* (coerce result 'list)) (let ((index (ensure-system-index directory))) (when index (with-open-file (stream index) (loop for line = (read-line stream nil) while line do (let ((pathname (merge-pathnames line index))) (unless (gethash (pathname-name pathname) seen) (setf (gethash (pathname-name pathname) seen) t) (vector-push-extend (merge-pathnames line index) result)))))))))) (defun register-local-projects () "Force a scan of the local projects directory to create the system file index." (map nil 'make-system-index *local-project-directories*)) (defun list-local-systems () "Return a list of local project system names." (mapcar #'pathname-name (list-local-projects))) quicklisp/minitar.lisp000066400000000000000000000154461401210150300154130ustar00rootroot00000000000000(in-package #:ql-minitar) (defconstant +block-size+ 512) (defconstant +space-code+ 32) (defconstant +newline-code+ 10) (defconstant +equals-code+ 61) (defun make-block-buffer () (make-array +block-size+ :element-type '(unsigned-byte 8) :initial-element 0)) (defun skip-n-blocks (n stream) (let ((block (make-block-buffer))) (dotimes (i n) (read-sequence block stream)))) (defun read-octet-vector (length stream) (let ((block (make-block-buffer)) (vector (make-array length :element-type '(unsigned-byte 8))) (offset 0) (block-count (ceiling length +block-size+))) (dotimes (i block-count) (read-sequence block stream) (replace vector block :start1 offset) (incf offset +block-size+)) vector)) (defun decode-pax-header-record (vector offset) "Decode VECTOR as pax extended header data. Returns the keyword and value it specifies as multiple values." ;; Vector format is: "%d %s=%s\n", , , ;; See http://pubs.opengroup.org/onlinepubs/009695399/utilities/pax.html (let* ((length-start offset) (length-end (position +space-code+ vector :start length-start)) (length-string (ascii-subseq vector length-start length-end)) (length (parse-integer length-string)) (keyword-start (1+ length-end)) (keyword-end (position +equals-code+ vector :start keyword-start)) (keyword (ascii-subseq vector keyword-start keyword-end)) (value-start (1+ keyword-end)) (value-end (1- (+ offset length))) (value (ascii-subseq vector value-start value-end))) (values keyword value (+ offset length)))) (defun decode-pax-header (vector) "Decode VECTOR as a pax header and return it as an alist." (let ((header nil) (offset 0) (length (length vector))) (loop (when (<= length offset) (return header)) (multiple-value-bind (keyword value new-offset) (decode-pax-header-record vector offset) (setf header (acons keyword value header)) (setf offset new-offset))))) (defun pax-header-path (vector) "Decode VECTOR as a pax header and return its 'path' value, if any." (let ((header-alist (decode-pax-header vector))) (cdr (assoc "path" header-alist :test 'equal)))) (defun ascii-subseq (vector start end) (let ((string (make-string (- end start)))) (loop for i from 0 for j from start below end do (setf (char string i) (code-char (aref vector j)))) string)) (defun block-asciiz-string (block start length) (let* ((end (+ start length)) (eos (or (position 0 block :start start :end end) end))) (ascii-subseq block start eos))) (defun prefix (header) (when (plusp (aref header 345)) (block-asciiz-string header 345 155))) (defun name (header) (block-asciiz-string header 0 100)) (defun payload-size (header) (values (parse-integer (block-asciiz-string header 124 12) :radix 8))) (defun nth-block (n file) (with-open-file (stream file :element-type '(unsigned-byte 8)) (let ((block (make-block-buffer))) (skip-n-blocks (1- n) stream) (read-sequence block stream) block))) (defun payload-type (code) (case code (0 :file) (48 :file) (50 :symlink) (76 :long-name) (53 :directory) (103 :global-header) (120 :pax-extended-header) (t :unsupported))) (defun full-path (header) (let ((prefix (prefix header)) (name (name header))) (if prefix (format nil "~A/~A" prefix name) name))) (defun save-file (file size stream) (multiple-value-bind (full-blocks partial) (truncate size +block-size+) (ensure-directories-exist file) (with-open-file (outstream file :direction :output :if-exists :supersede :element-type '(unsigned-byte 8)) (let ((block (make-block-buffer))) (dotimes (i full-blocks) (read-sequence block stream) (write-sequence block outstream)) (when (plusp partial) (read-sequence block stream) (write-sequence block outstream :end partial)))))) (defun gnu-long-name (size stream) ;; GNU long names are simply the filename (null terminated) packed into the ;; payload. (let ((payload (read-octet-vector size stream))) (ascii-subseq payload 0 (1- size)))) (defun unpack-tarball (tarfile &key (directory *default-pathname-defaults*)) (let ((block (make-block-buffer)) (extended-path nil)) (with-open-file (stream tarfile :element-type '(unsigned-byte 8)) (loop (let ((size (read-sequence block stream))) (when (zerop size) (return)) (unless (= size +block-size+) (error "Bad size on tarfile")) (when (every #'zerop block) (return)) (let* ((payload-code (aref block 156)) (payload-type (payload-type payload-code)) (tar-path (or (shiftf extended-path nil) (full-path block))) (full-path (merge-pathnames tar-path directory)) (payload-size (payload-size block)) (block-count (ceiling (payload-size block) +block-size+))) (case payload-type (:file (save-file full-path payload-size stream)) (:directory (ensure-directories-exist full-path)) ((:symlink :global-header) ;; These block types aren't required for Quicklisp archives (skip-n-blocks block-count stream)) (:long-name (setf extended-path (gnu-long-name payload-size stream))) (:pax-extended-header (let* ((pax-header-data (read-octet-vector payload-size stream)) (path (pax-header-path pax-header-data))) (when path (setf extended-path path)))) (t (warn "Unknown tar block payload code -- ~D" payload-code) (skip-n-blocks block-count stream))))))))) (defun contents (tarfile) (let ((block (make-block-buffer)) (result '())) (with-open-file (stream tarfile :element-type '(unsigned-byte 8)) (loop (let ((size (read-sequence block stream))) (when (zerop size) (return (nreverse result))) (unless (= size +block-size+) (error "Bad size on tarfile")) (when (every #'zerop block) (return (nreverse result))) (let* ((payload-type (payload-type (aref block 156))) (tar-path (full-path block)) (payload-size (payload-size block))) (skip-n-blocks (ceiling payload-size +block-size+) stream) (case payload-type (:file (push tar-path result)) (:directory (push tar-path result))))))))) quicklisp/misc.lisp000066400000000000000000000011131401210150300146650ustar00rootroot00000000000000;;;; misc.lisp (in-package #:quicklisp-client) ;;; ;;; This stuff will probably end up somewhere else. ;;; (defun use-only-quicklisp-systems () (asdf:initialize-source-registry '(:source-registry :ignore-inherited-configuration)) (asdf:map-systems 'asdf:clear-system) t) (defun who-depends-on (system-name) "Return a list of names of systems that depend on SYSTEM-NAME." (setf system-name (string-downcase system-name)) (loop for system in (provided-systems t) when (member system-name (required-systems system) :test 'string=) collect (name system))) quicklisp/network.lisp000066400000000000000000000132071401210150300154320ustar00rootroot00000000000000;;; ;;; Low-level networking implementations ;;; (in-package #:ql-network) (definterface host-address (host) (:implementation t host) (:implementation sbcl (ql-sbcl:host-ent-address (ql-sbcl:get-host-by-name host)))) (definterface open-connection (host port) (:documentation "Open and return a network connection to HOST on the given PORT.") (:implementation t (declare (ignore host port)) (error "Sorry, quicklisp in implementation ~S is not supported yet." (lisp-implementation-type))) (:implementation allegro (ql-allegro:make-socket :remote-host host :remote-port port)) (:implementation abcl (let ((socket (ql-abcl:make-socket host port))) (ql-abcl:get-socket-stream socket :element-type '(unsigned-byte 8)))) (:implementation ccl (ql-ccl:make-socket :remote-host host :remote-port port)) (:implementation clasp (let* ((endpoint (ql-clasp:host-ent-address (ql-clasp:get-host-by-name host))) (socket (make-instance 'ql-clasp:inet-socket :protocol :tcp :type :stream))) (ql-clasp:socket-connect socket endpoint port) (ql-clasp:socket-make-stream socket :element-type '(unsigned-byte 8) :input t :output t :buffering :full))) (:implementation clisp (ql-clisp:socket-connect port host :element-type '(unsigned-byte 8))) (:implementation cmucl (let ((fd (ql-cmucl:connect-to-inet-socket host port))) (ql-cmucl:make-fd-stream fd :element-type '(unsigned-byte 8) :binary-stream-p t :input t :output t))) (:implementation scl (let ((fd (ql-scl:connect-to-inet-socket host port))) (ql-scl:make-fd-stream fd :element-type '(unsigned-byte 8) :input t :output t))) (:implementation ecl (let* ((endpoint (ql-ecl:host-ent-address (ql-ecl:get-host-by-name host))) (socket (make-instance 'ql-ecl:inet-socket :protocol :tcp :type :stream))) (ql-ecl:socket-connect socket endpoint port) (ql-ecl:socket-make-stream socket :element-type '(unsigned-byte 8) :input t :output t :buffering :full))) (:implementation mezzano (ql-mezzano:tcp-stream-connect host port :element-type '(unsigned-byte 8))) (:implementation mkcl (let* ((endpoint (ql-mkcl:host-ent-address (ql-mkcl:get-host-by-name host))) (socket (make-instance 'ql-mkcl:inet-socket :protocol :tcp :type :stream))) (ql-mkcl:socket-connect socket endpoint port) (ql-mkcl:socket-make-stream socket :element-type '(unsigned-byte 8) :input t :output t :buffering :full))) (:implementation lispworks (ql-lispworks:open-tcp-stream host port :direction :io :errorp t :read-timeout nil :element-type '(unsigned-byte 8) :timeout 5)) (:implementation sbcl (let* ((endpoint (ql-sbcl:host-ent-address (ql-sbcl:get-host-by-name host))) (socket (make-instance 'ql-sbcl:inet-socket :protocol :tcp :type :stream))) (ql-sbcl:socket-connect socket endpoint port) (ql-sbcl:socket-make-stream socket :element-type '(unsigned-byte 8) :input t :output t :buffering :full)))) (definterface read-octets (buffer connection) (:documentation "Read from CONNECTION into BUFFER. Returns the number of octets read.") (:implementation t (read-sequence buffer connection)) (:implementation allegro (ql-allegro:read-vector buffer connection)) (:implementation clisp (ql-clisp:read-byte-sequence buffer connection :no-hang nil :interactive t))) (definterface write-octets (buffer connection) (:documentation "Write the contents of BUFFER to CONNECTION.") (:implementation t (write-sequence buffer connection) (finish-output connection))) (definterface close-connection (connection) (:implementation t (ignore-errors (close connection)))) (definterface call-with-connection (host port fun) (:documentation "Establish a network connection to HOST on PORT and call FUN with that connection as the only argument. Unconditionally closes the connection afterwareds via CLOSE-CONNECTION in an unwind-protect. See also WITH-CONNECTION.") (:implementation t (let (connection) (unwind-protect (progn (setf connection (open-connection host port)) (funcall fun connection)) (when connection (close-connection connection)))))) (defmacro with-connection ((connection host port) &body body) `(call-with-connection ,host ,port (lambda (,connection) ,@body))) quicklisp/package.lisp000066400000000000000000000221461401210150300153360ustar00rootroot00000000000000;;;; package.lisp (defpackage #:ql-util (:documentation "Utility functions used in various places.") (:use #:cl) (:export #:write-line-to-file #:without-prompting #:press-enter-to-continue #:replace-file #:copy-file #:delete-file-if-exists #:ensure-file-exists #:split-spaces #:first-line #:file-size #:safely-read #:safely-read-file #:make-versions-url #:with-temporary-file)) (defpackage #:ql-setup (:documentation "Functions and variables initialized early in the Quicklisp client configuration.") (:use #:cl) (:export #:qmerge #:qenough #:*quicklisp-home*)) (defpackage #:ql-config (:documentation "Getting and setting persistent configuration values.") (:use #:cl #:ql-util #:ql-setup) (:export #:config-value)) (defpackage #:ql-impl (:documentation "Configuration of implementation-specific packages and interfaces.") (:use #:cl) (:export #:*implementation*) (:export #:definterface #:defimplementation #:show-interfaces) (:export #:lisp #:abcl #:allegro #:ccl #:clasp #:clisp #:cmucl #:cormanlisp #:ecl #:gcl #:lispworks #:mezzano #:mkcl #:scl #:sbcl)) (defpackage #:ql-impl-util (:documentation "Utility functions that require implementation-specific functionality.") (:use #:cl #:ql-impl) (:export #:call-with-quiet-compilation #:add-to-init-file #:rename-directory #:delete-directory #:probe-directory #:directory-entries #:delete-directory-tree #:map-directory-tree #:native-namestring #:directory-write-date)) (defpackage #:ql-network (:documentation "Simple, low-level network access.") (:use #:cl #:ql-impl) (:export #:open-connection #:write-octets #:read-octets #:close-connection #:with-connection)) (defpackage #:ql-progress (:documentation "Displaying a progress bar.") (:use #:cl) (:export #:make-progress-bar #:start-display #:update-progress #:finish-display)) (defpackage #:ql-http (:documentation "A simple HTTP client.") (:use #:cl #:ql-network #:ql-progress #:ql-config) (:export #:*proxy-url* #:fetch #:http-fetch #:*fetch-scheme-functions* #:scheme #:hostname #:port #:path #:url #:*maximum-redirects* #:*default-url-defaults*) (:export #:fetch-error #:unexpected-http-status #:unexpected-http-status-code #:unexpected-http-status-url #:too-many-redirects #:too-many-redirects-url #:too-many-redirects-count)) (defpackage #:ql-minitar (:documentation "A simple implementation of unpacking the 'tar' file format.") (:use #:cl) (:export #:unpack-tarball)) (defpackage #:ql-gunzipper (:documentation "An implementation of gunzip.") (:use #:cl) (:export #:gunzip)) (defpackage #:ql-cdb (:documentation "Read and write CDB files; code adapted from ZCDB.") (:use #:cl) (:export #:lookup #:map-cdb #:convert-index-file)) (defpackage #:ql-dist (:documentation "Generic functions, variables, and classes for interacting with the dist system. Documented, exported symbols are intended for public use.") (:use #:cl #:ql-util #:ql-http #:ql-setup #:ql-gunzipper #:ql-minitar) (:intern #:dist-version #:dist-url) (:import-from #:ql-impl-util #:delete-directory-tree #:directory-entries #:probe-directory) ;; Install/enable protocol (:export #:installedp #:install #:uninstall #:ensure-installed #:enabledp #:enable #:disable) ;; Preference protocol (:export #:preference #:preference-file #:preference-parent #:forget-preference) ;; Generic (:export #:all-dists #:canonical-distinfo-url #:enabled-dists #:find-dist #:find-dist-or-lose #:find-system #:find-release #:dist #:system #:release #:base-directory #:relative-to #:metadata-name #:install-metadata-file #:short-description #:provided-releases #:provided-systems #:installed-releases #:installed-systems #:name) ;; Dists (:export #:dist #:dist-merge #:find-system-in-dist #:find-release-in-dist #:system-index-url #:release-index-url #:available-versions-url #:available-versions #:version #:subscription-url #:new-version-available-p #:dist-difference #:fetch-dist #:initialize-release-index #:initialize-system-index #:with-consistent-dists) ;; Dist updates (:export #:available-update #:update-release-differences #:show-update-report #:update-in-place #:install-dist #:subscription-inhibition-file #:inhibit-subscription #:uninhibit-subscription #:subscription-inhibited-p #:subscription-unavailable #:subscribedp #:subscribe #:unsubscribe) ;; Releases (:export #:release #:project-name #:system-files #:archive-url #:archive-size #:ensure-archive-file #:archive-content-sha1 #:archive-md5 #:prefix #:local-archive-file #:ensure-local-archive-file #:check-local-archive-file #:invalid-local-archive #:invalid-local-archive-file #:invalid-local-archive-release #:missing-local-archive #:badly-sized-local-archive #:delete-and-retry) ;; Systems (:export #:dist #:release #:preference #:system-file-name #:required-systems) ;; Misc (:export #:standard-dist-enumeration-function #:*dist-enumeration-functions* #:find-asdf-system-file #:system-definition-searcher #:system-apropos #:system-apropos-list #:dependency-tree #:clean #:unknown-dist)) (defpackage #:ql-dist-user (:documentation "A package that uses QL-DIST; useful for playing around in without clobbering any QL-DIST internals.") (:use #:cl #:ql-dist)) (defpackage #:ql-bundle (:documentation "A package for supporting the QL:BUNDLE-SYSTEMS function.") (:use #:cl #:ql-dist #:ql-impl-util) (:shadow #:find-system #:find-release) (:export #:bundle #:requested-systems #:ensure-system #:ensure-release #:write-bundle #:add-systems-recursively #:object-not-found #:system-not-found #:system-not-found-system #:release-not-found #:bundle-directory-exists #:bundle-directory-exists-directory)) (defpackage #:quicklisp-client (:documentation "The Quicklisp client package, intended for end-user Quicklisp commands and configuration parameters.") (:nicknames #:quicklisp #:ql) (:use #:cl #:ql-util #:ql-impl-util #:ql-dist #:ql-http #:ql-setup #:ql-config #:ql-minitar #:ql-gunzipper) (:shadow #:uninstall) (:shadowing-import-from #:ql-dist #:dist-version #:dist-url) (:export #:dist-version #:dist-url) (:export #:quickload #:*quickload-prompt* #:*quickload-verbose* #:*quickload-explain* #:system-not-found #:system-not-found-name #:uninstall #:uninstall-dist #:qmerge #:*quicklisp-home* #:*initial-dist-url* #:*proxy-url* #:config-value #:setup #:provided-systems #:system-apropos #:system-apropos-list #:system-list #:client-version #:client-url #:available-client-versions #:install-client #:update-client #:update-dist #:update-all-dists #:available-dist-versions #:add-to-init-file #:use-only-quicklisp-systems #:write-asdf-manifest-file #:where-is-system #:help #:register-local-projects #:local-projects-searcher #:*local-project-directories* #:list-local-projects #:list-local-systems #:who-depends-on #:bundle-systems)) (in-package #:quicklisp-client) quicklisp/progress.lisp000066400000000000000000000117541401210150300156120ustar00rootroot00000000000000;;; ;;; A text progress bar ;;; (in-package #:ql-progress) (defclass progress-bar () ((start-time :initarg :start-time :accessor start-time) (end-time :initarg :end-time :accessor end-time) (progress-character :initarg :progress-character :accessor progress-character) (character-count :initarg :character-count :accessor character-count :documentation "How many characters wide is the progress bar?") (characters-so-far :initarg :characters-so-far :accessor characters-so-far) (update-interval :initarg :update-interval :accessor update-interval :documentation "Update the progress bar display after this many internal-time units.") (last-update-time :initarg :last-update-time :accessor last-update-time :documentation "The display was last updated at this time.") (total :initarg :total :accessor total :documentation "The total number of units tracked by this progress bar.") (progress :initarg :progress :accessor progress :documentation "How far in the progress are we?") (pending :initarg :pending :accessor pending :documentation "How many raw units should be tracked in the next display update?")) (:default-initargs :progress-character #\= :character-count 50 :characters-so-far 0 :update-interval (floor internal-time-units-per-second 4) :last-update-time 0 :total 0 :progress 0 :pending 0)) (defgeneric start-display (progress-bar)) (defgeneric update-progress (progress-bar unit-count)) (defgeneric update-display (progress-bar)) (defgeneric finish-display (progress-bar)) (defgeneric elapsed-time (progress-bar)) (defgeneric units-per-second (progress-bar)) (defmethod start-display (progress-bar) (setf (last-update-time progress-bar) (get-internal-real-time)) (setf (start-time progress-bar) (get-internal-real-time)) (fresh-line) (finish-output)) (defmethod update-display (progress-bar) (incf (progress progress-bar) (pending progress-bar)) (setf (pending progress-bar) 0) (setf (last-update-time progress-bar) (get-internal-real-time)) (let* ((showable (floor (character-count progress-bar) (/ (total progress-bar) (progress progress-bar)))) (needed (- showable (characters-so-far progress-bar)))) (setf (characters-so-far progress-bar) showable) (dotimes (i needed) (write-char (progress-character progress-bar))) (finish-output))) (defmethod update-progress (progress-bar unit-count) (incf (pending progress-bar) unit-count) (let ((now (get-internal-real-time))) (when (< (update-interval progress-bar) (- now (last-update-time progress-bar))) (update-display progress-bar)))) (defmethod finish-display (progress-bar) (update-display progress-bar) (setf (end-time progress-bar) (get-internal-real-time)) (terpri) (format t "~:D bytes in ~$ seconds (~$KB/sec)~%" (total progress-bar) (elapsed-time progress-bar) (/ (units-per-second progress-bar) 1024)) (finish-output)) (defmethod elapsed-time (progress-bar) (/ (- (end-time progress-bar) (start-time progress-bar)) internal-time-units-per-second)) (defmethod units-per-second (progress-bar) (if (plusp (elapsed-time progress-bar)) (/ (total progress-bar) (elapsed-time progress-bar)) 0)) (defun kb/sec (progress-bar) (/ (units-per-second progress-bar) 1024)) (defparameter *uncertain-progress-chars* "?") (defclass uncertain-size-progress-bar (progress-bar) ((progress-char-index :initarg :progress-char-index :accessor progress-char-index) (units-per-char :initarg :units-per-char :accessor units-per-char)) (:default-initargs :total 0 :progress-char-index 0 :units-per-char (floor (expt 1024 2) 50))) (defmethod update-progress :after ((progress-bar uncertain-size-progress-bar) unit-count) (incf (total progress-bar) unit-count)) (defmethod progress-character ((progress-bar uncertain-size-progress-bar)) (let ((index (progress-char-index progress-bar))) (prog1 (char *uncertain-progress-chars* index) (setf (progress-char-index progress-bar) (mod (1+ index) (length *uncertain-progress-chars*)))))) (defmethod update-display ((progress-bar uncertain-size-progress-bar)) (setf (last-update-time progress-bar) (get-internal-real-time)) (multiple-value-bind (chars pend) (floor (pending progress-bar) (units-per-char progress-bar)) (setf (pending progress-bar) pend) (dotimes (i chars) (write-char (progress-character progress-bar)) (incf (characters-so-far progress-bar)) (when (<= (character-count progress-bar) (characters-so-far progress-bar)) (terpri) (setf (characters-so-far progress-bar) 0) (finish-output))) (finish-output))) (defun make-progress-bar (total) (if (or (not total) (zerop total)) (make-instance 'uncertain-size-progress-bar) (make-instance 'progress-bar :total total))) quicklisp/quicklisp.asd000066400000000000000000000021351401210150300155430ustar00rootroot00000000000000;;;; quicklisp.asd (defpackage #:ql-info (:export #:*version*)) (defvar ql-info:*version* (with-open-file (stream (merge-pathnames "version.txt" *load-truename*)) (read-line stream))) (asdf:defsystem #:quicklisp :description "The Quicklisp client application." :author "Zach Beane " :license "BSD-style" :serial t :version #.(remove-if-not #'digit-char-p ql-info:*version*) :components ((:file "package") (:file "utils") (:file "config") (:file "impl") (:file "impl-util") (:file "network") (:file "progress") (:file "http") (:file "deflate") (:file "minitar") (:file "cdb") (:file "dist") (:file "setup") (:file "client") (:file "fetch-gzipped") (:file "client-info") (:file "client-update") (:file "dist-update") (:file "misc") (:file "local-projects") (:file "bundle"))) quicklisp/setup.lisp000066400000000000000000000236001401210150300150770ustar00rootroot00000000000000(in-package #:quicklisp) (defun show-wrapped-list (words &key (indent 4) (margin 60)) (let ((*print-right-margin* margin) (*print-pretty* t) (*print-escape* nil) (prefix (make-string indent :initial-element #\Space))) (pprint-logical-block (nil words :per-line-prefix prefix) (pprint-fill *standard-output* (sort (copy-seq words) #'string<) nil)) (fresh-line) (finish-output))) (defun recursively-install (name) (labels ((recurse (name) (let ((system (find-system name))) (unless system (error "Unknown system ~S" name)) (ensure-installed system) (mapcar #'recurse (required-systems system)) name))) (with-consistent-dists (recurse name)))) (defclass load-strategy () ((name :initarg :name :accessor name) (asdf-systems :initarg :asdf-systems :accessor asdf-systems) (quicklisp-systems :initarg :quicklisp-systems :accessor quicklisp-systems))) (defmethod print-object ((strategy load-strategy) stream) (print-unreadable-object (strategy stream :type t) (format stream "~S (~D asdf, ~D quicklisp)" (name strategy) (length (asdf-systems strategy)) (length (quicklisp-systems strategy))))) (defgeneric quicklisp-releases (strategy) (:method (strategy) (remove-duplicates (mapcar 'release (quicklisp-systems strategy))))) (defgeneric quicklisp-release-table (strategy) (:method ((strategy load-strategy)) (let ((table (make-hash-table))) (dolist (system (quicklisp-systems strategy)) (push system (gethash (release system) table nil))) table))) (define-condition system-not-found (error) ((name :initarg :name :reader system-not-found-name)) (:report (lambda (condition stream) (format stream "System ~S not found" (system-not-found-name condition)))) (:documentation "This condition is signaled by QUICKLOAD when a system given to load is not available via ASDF or a Quicklisp dist.")) (defun compute-load-strategy (name) (setf name (string-downcase name)) (let ((asdf-systems '()) (quicklisp-systems '())) (labels ((recurse (name) (let ((asdf-system (asdf:find-system name nil)) (quicklisp-system (find-system name))) (cond (asdf-system (push asdf-system asdf-systems)) (quicklisp-system (push quicklisp-system quicklisp-systems) (dolist (subname (required-systems quicklisp-system)) (recurse subname))) (t (cerror "Try again" 'system-not-found :name name) (recurse name)))))) (with-consistent-dists (recurse name))) (make-instance 'load-strategy :name name :asdf-systems (remove-duplicates asdf-systems) :quicklisp-systems (remove-duplicates quicklisp-systems)))) (defun show-load-strategy (strategy) (format t "To load ~S:~%" (name strategy)) (let ((asdf-systems (asdf-systems strategy)) (releases (quicklisp-releases strategy))) (when asdf-systems (format t " Load ~D ASDF system~:P:~%" (length asdf-systems)) (show-wrapped-list (mapcar 'asdf:component-name asdf-systems))) (when releases (format t " Install ~D Quicklisp release~:P:~%" (length releases)) (show-wrapped-list (mapcar 'name releases))))) (defvar *macroexpand-progress-in-progress* nil) (defun macroexpand-progress-fun (old-hook &key (char #\.) (chars-per-line 50) (forms-per-char 250)) (let ((output-so-far 0) (seen-so-far 0)) (labels ((finish-line () (when (plusp output-so-far) (dotimes (i (- chars-per-line output-so-far)) (write-char char)) (terpri) (setf output-so-far 0))) (show-string (string) (let* ((length (length string)) (new-output (+ length output-so-far))) (cond ((< chars-per-line new-output) (finish-line) (write-string string) (setf output-so-far length)) (t (write-string string) (setf output-so-far new-output)))) (finish-output)) (show-package (name) ;; Only show package markers when compiling. Showing ;; them when loading shows a bunch of ASDF system ;; package noise. (when *compile-file-pathname* (finish-line) (show-string (format nil "[package ~(~A~)]" name))))) (lambda (fun form env) (when (and (consp form) (eq (first form) 'cl:defpackage) (ignore-errors (string (second form)))) (show-package (second form))) (incf seen-so-far) (when (<= forms-per-char seen-so-far) (setf seen-so-far 0) (write-char char) (finish-output) (incf output-so-far) (when (<= chars-per-line output-so-far) (setf output-so-far 0) (terpri) (finish-output))) (funcall old-hook fun form env))))) (defun call-with-macroexpand-progress (fun) (let ((*macroexpand-hook* (if *macroexpand-progress-in-progress* *macroexpand-hook* (macroexpand-progress-fun *macroexpand-hook*))) (*macroexpand-progress-in-progress* t)) (funcall fun) (terpri))) (defun apply-load-strategy (strategy) (map nil 'ensure-installed (quicklisp-releases strategy)) (call-with-macroexpand-progress (lambda () (format t "~&; Loading ~S~%" (name strategy)) (asdf:load-system (name strategy) :verbose nil)))) (defun autoload-system-and-dependencies (name &key prompt) "Try to load the system named by NAME, automatically loading any Quicklisp-provided systems first, and catching ASDF missing dependencies too if possible." (setf name (string-downcase name)) (with-simple-restart (abort "Give up on ~S" name) (let ((tried-so-far (make-hash-table :test 'equalp))) (tagbody retry (handler-case (let ((strategy (compute-load-strategy name))) (show-load-strategy strategy) (when (or (not prompt) (press-enter-to-continue)) (apply-load-strategy strategy))) (asdf:missing-dependency-of-version (c) ;; Nothing Quicklisp can do to recover from this, so just ;; resignal (error c)) (asdf:missing-dependency (c) (let ((parent (asdf::missing-required-by c)) (missing (asdf::missing-requires c))) (typecase parent ((or null asdf:system) ;; NIL parent comes from :defsystem-depends-on failures (if (gethash missing tried-so-far) (error "Dependency looping -- already tried to load ~ ~A" missing) (setf (gethash missing tried-so-far) missing)) (autoload-system-and-dependencies missing :prompt prompt) (go retry)) (t ;; Error isn't from a system dependency, so there's ;; nothing to autoload (error c)))))))) name)) (defvar *initial-dist-url* "http://beta.quicklisp.org/dist/quicklisp.txt") (defun dists-initialized-p () (not (not (ignore-errors (truename (qmerge "dists/")))))) (defun quickstart-parameter (name &optional default) (let* ((package (find-package '#:quicklisp-quickstart)) (symbol (and package (find-symbol (string '#:*quickstart-parameters*) package))) (plist (and symbol (symbol-value symbol))) (parameter (and plist (getf plist name)))) (or parameter default))) (defun maybe-initial-setup () "Run the steps needed when Quicklisp setup is run for the first time after the quickstart installation." (let ((quickstart-proxy-url (quickstart-parameter :proxy-url)) (quickstart-initial-dist-url (quickstart-parameter :initial-dist-url))) (when (and quickstart-proxy-url (not *proxy-url*)) (setf *proxy-url* quickstart-proxy-url) (setf (config-value "proxy-url") quickstart-proxy-url)) (unless (dists-initialized-p) (let ((target (qmerge "dists/quicklisp/distinfo.txt")) (url (or quickstart-initial-dist-url *initial-dist-url*))) (ensure-directories-exist target) (install-dist url :prompt nil))))) (defun setup () (unless (member 'system-definition-searcher asdf:*system-definition-search-functions*) (setf asdf:*system-definition-search-functions* (append asdf:*system-definition-search-functions* (list 'local-projects-searcher 'system-definition-searcher)))) (let ((files (nconc (directory (qmerge "local-init/*.lisp")) (directory (qmerge "local-init/*.cl"))))) (with-simple-restart (abort "Stop loading local setup files") (dolist (file (sort files #'string< :key #'pathname-name)) (with-simple-restart (skip "Skip local setup file ~S" file) ;; Don't try to load Emacs lock files, other hidden files (unless (char= (char (pathname-name file) 0) #\.) (load file)))))) (maybe-initial-setup) (ensure-directories-exist (qmerge "local-projects/")) (pushnew :quicklisp *features*) t) quicklisp/utils.lisp000066400000000000000000000121051401210150300150750ustar00rootroot00000000000000;;;; utils.lisp (in-package #:ql-util) (defun write-line-to-file (string file) (with-open-file (stream file :direction :output :if-exists :supersede) (write-line string stream))) (defvar *do-not-prompt* nil "When *DO-NOT-PROMPT* is true, PRESS-ENTER-TO-CONTINUE returns true without user interaction.") (defmacro without-prompting (&body body) "Evaluate BODY in an environment where PRESS-ENTER-TO-CONTINUE always returns true without prompting for the user to press enter." `(let ((*do-not-prompt* t)) ,@body)) (defun press-enter-to-continue () (when *do-not-prompt* (return-from press-enter-to-continue t)) (format *query-io* "~&Press Enter to continue.~%") (let ((result (read-line *query-io*))) (zerop (length result)))) (defun replace-file (from to) "Like RENAME-FILE, but deletes TO if it exists, first." (when (probe-file to) (delete-file to)) (rename-file from to)) (defun copy-file (from to &key (if-exists :rename-and-delete)) "Copy the file FROM to TO." (let* ((buffer-size 8192) (buffer (make-array buffer-size :element-type '(unsigned-byte 8)))) (with-open-file (from-stream from :element-type '(unsigned-byte 8)) (with-open-file (to-stream to :element-type '(unsigned-byte 8) :direction :output :if-exists if-exists) (let ((length (file-length from-stream))) (multiple-value-bind (full leftover) (floor length buffer-size) (dotimes (i full) (read-sequence buffer from-stream) (write-sequence buffer to-stream)) (read-sequence buffer from-stream) (write-sequence buffer to-stream :end leftover))))) (probe-file to))) (defun ensure-file-exists (pathname) (open pathname :direction :probe :if-does-not-exist :create)) (defun delete-file-if-exists (pathname) (when (probe-file pathname) (delete-file pathname))) (defun split-spaces (line) (let ((words '()) (mark 0) (pos 0)) (labels ((finish () (setf pos (length line)) (save) (return-from split-spaces (nreverse words))) (save () (when (< mark pos) (push (subseq line mark pos) words))) (mark () (setf mark pos)) (in-word (char) (case char (#\Space (save) #'in-space) (t #'in-word))) (in-space (char) (case char (#\Space #'in-space) (t (mark) #'in-word)))) (let ((state #'in-word)) (dotimes (i (length line) (finish)) (setf pos i) (setf state (funcall state (char line i)))))))) (defun first-line (file) (with-open-file (stream file) (values (read-line stream)))) (defun (setf first-line) (line file) (with-open-file (stream file :direction :output :if-exists :rename-and-delete) (write-line line stream))) (defun file-size (file) (with-open-file (stream file :element-type '(unsigned-byte 8)) (file-length stream))) (defun safely-read (stream) "Read one form from STREAM with *READ-EVAL* bound to NIL." (let ((*read-eval* nil)) (read stream))) (defun safely-read-file (file) "Read the first form from FILE with SAFELY-READ." (with-open-file (stream file) (safely-read stream))) (defun make-versions-url (url) "Given an URL that looks like http://foo/bar.ext, return http://foo/bar-versions.txt." (let ((suffix-pos (position #\. url :from-end t))) (unless suffix-pos (error "Can't make a versions URL from ~A" url)) (let ((extension (subseq url suffix-pos))) (concatenate 'string (subseq url 0 suffix-pos) "-versions" extension)))) (defun call-with-temporary-file (fun template-pathname) (assert (null (pathname-directory template-pathname))) (let* ((relative-file (merge-pathnames template-pathname #p"tmp/")) (absolute-file (ql-setup:qmerge relative-file)) (randomized-file (make-pathname :name (format nil "~A-~36,5,'0R" (pathname-name template-pathname) (random #xFFFFFF)) :defaults absolute-file))) (unwind-protect (funcall fun randomized-file) (delete-file-if-exists randomized-file)))) ;;; TODO: Use this where (qmerge "tmp/...") is used, when possible (defmacro with-temporary-file ((var template) &body body) "Evaluate BODY with VAR bound to a temporary pathname created by adding random data to the pathname-name of TEMPLATE, which should be a pathname without a directory component. After evaluation, the temporary pathname is deleted if it exists." `(call-with-temporary-file (lambda (,var) ,@body) ,template)) quicklisp/version.txt000066400000000000000000000000131401210150300152650ustar00rootroot000000000000002021-02-13