| 1 | (in-package #:asdf-install) |
|---|
| 2 | |
|---|
| 3 | (pushnew :asdf-install *features*) |
|---|
| 4 | |
|---|
| 5 | (defun installer-msg (stream format-control &rest format-arguments) |
|---|
| 6 | (apply #'format stream "~&;;; ASDF-INSTALL: ~@?~%" |
|---|
| 7 | format-control format-arguments)) |
|---|
| 8 | |
|---|
| 9 | (defun verify-gpg-signatures-p (url) |
|---|
| 10 | (labels ((prefixp (prefix string) |
|---|
| 11 | (let ((m (mismatch prefix string))) |
|---|
| 12 | (or (not m) (>= m (length prefix)))))) |
|---|
| 13 | (case *verify-gpg-signatures* |
|---|
| 14 | ((nil) nil) |
|---|
| 15 | ((:unknown-locations) |
|---|
| 16 | (notany |
|---|
| 17 | (lambda (x) (prefixp x url)) |
|---|
| 18 | *safe-url-prefixes*)) |
|---|
| 19 | (t t)))) |
|---|
| 20 | |
|---|
| 21 | (defun same-central-registry-entry-p (a b) |
|---|
| 22 | (flet ((ensure-string (x) |
|---|
| 23 | (typecase x |
|---|
| 24 | (string x) |
|---|
| 25 | (pathname (namestring (translate-logical-pathname x))) |
|---|
| 26 | (t nil)))) |
|---|
| 27 | (and (setf a (ensure-string a)) |
|---|
| 28 | (setf b (ensure-string b)) |
|---|
| 29 | a b (string-equal a b)))) |
|---|
| 30 | |
|---|
| 31 | (defun add-registry-location (location) |
|---|
| 32 | (let ((location-directory (pathname-sans-name+type location))) |
|---|
| 33 | #+asdf |
|---|
| 34 | (pushnew location-directory |
|---|
| 35 | asdf:*central-registry* |
|---|
| 36 | :test #'same-central-registry-entry-p) |
|---|
| 37 | |
|---|
| 38 | #+mk-defsystem |
|---|
| 39 | (mk:add-registry-location location-directory))) |
|---|
| 40 | |
|---|
| 41 | ;;; Fixing the handling of *LOCATIONS* |
|---|
| 42 | |
|---|
| 43 | (defun add-locations (loc-name site system-site) |
|---|
| 44 | (declare (type string loc-name) |
|---|
| 45 | (type pathname site system-site)) |
|---|
| 46 | #+asdf |
|---|
| 47 | (progn |
|---|
| 48 | (pushnew site asdf:*central-registry* :test #'equal) |
|---|
| 49 | (pushnew system-site asdf:*central-registry* :test #'equal)) |
|---|
| 50 | |
|---|
| 51 | #+mk-defsystem |
|---|
| 52 | (progn |
|---|
| 53 | (mk:add-registry-location site) |
|---|
| 54 | (mk:add-registry-location system-site)) |
|---|
| 55 | (setf *locations* |
|---|
| 56 | (append *locations* (list (list site system-site loc-name))))) |
|---|
| 57 | |
|---|
| 58 | ;;;--------------------------------------------------------------------------- |
|---|
| 59 | ;;; URL handling. |
|---|
| 60 | |
|---|
| 61 | (defun url-host (url) |
|---|
| 62 | (assert (string-equal url "http://" :end1 7)) |
|---|
| 63 | (let* ((port-start (position #\: url :start 7)) |
|---|
| 64 | (host-end (min (or (position #\/ url :start 7) (length url)) |
|---|
| 65 | (or port-start (length url))))) |
|---|
| 66 | (subseq url 7 host-end))) |
|---|
| 67 | |
|---|
| 68 | (defun url-port (url) |
|---|
| 69 | (assert (string-equal url "http://" :end1 7)) |
|---|
| 70 | (let ((port-start (position #\: url :start 7))) |
|---|
| 71 | (if port-start |
|---|
| 72 | (parse-integer url :start (1+ port-start) :junk-allowed t) 80))) |
|---|
| 73 | |
|---|
| 74 | ; This is from Juri Pakaste's <juri@iki.fi> base64.lisp |
|---|
| 75 | (defparameter *encode-table* |
|---|
| 76 | "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=") |
|---|
| 77 | |
|---|
| 78 | (defun base64-encode (string) |
|---|
| 79 | (let ((result (make-array |
|---|
| 80 | (list (* 4 (truncate (/ (+ 2 (length string)) 3)))) |
|---|
| 81 | :element-type 'base-char))) |
|---|
| 82 | (do ((sidx 0 (+ sidx 3)) |
|---|
| 83 | (didx 0 (+ didx 4)) |
|---|
| 84 | (chars 2 2) |
|---|
| 85 | (value nil nil)) |
|---|
| 86 | ((>= sidx (length string)) t) |
|---|
| 87 | (setf value (ash (logand #xFF (char-code (char string sidx))) 8)) |
|---|
| 88 | (dotimes (n 2) |
|---|
| 89 | (when (< (+ sidx n 1) (length string)) |
|---|
| 90 | (setf value |
|---|
| 91 | (logior value |
|---|
| 92 | (logand #xFF (char-code (char string (+ sidx n 1)))))) |
|---|
| 93 | (incf chars)) |
|---|
| 94 | (when (= n 0) |
|---|
| 95 | (setf value (ash value 8)))) |
|---|
| 96 | (setf (elt result (+ didx 3)) |
|---|
| 97 | (elt *encode-table* (if (> chars 3) (logand value #x3F) 64))) |
|---|
| 98 | (setf value (ash value -6)) |
|---|
| 99 | (setf (elt result (+ didx 2)) |
|---|
| 100 | (elt *encode-table* (if (> chars 2) (logand value #x3F) 64))) |
|---|
| 101 | (setf value (ash value -6)) |
|---|
| 102 | (setf (elt result (+ didx 1)) |
|---|
| 103 | (elt *encode-table* (logand value #x3F))) |
|---|
| 104 | (setf value (ash value -6)) |
|---|
| 105 | (setf (elt result didx) |
|---|
| 106 | (elt *encode-table* (logand value #x3F)))) |
|---|
| 107 | result)) |
|---|
| 108 | |
|---|
| 109 | (defun request-uri (url) |
|---|
| 110 | (assert (string-equal url "http://" :end1 7)) |
|---|
| 111 | (if *proxy* |
|---|
| 112 | url |
|---|
| 113 | (let ((path-start (position #\/ url :start 7))) |
|---|
| 114 | (assert (and path-start) nil "url does not specify a file.") |
|---|
| 115 | (subseq url path-start)))) |
|---|
| 116 | |
|---|
| 117 | (defun url-connection (url) |
|---|
| 118 | (let ((stream (make-stream-from-url (or *proxy* url))) |
|---|
| 119 | (host (url-host url))) |
|---|
| 120 | (format stream "GET ~A HTTP/1.0~C~CHost: ~A~C~CCookie: CCLAN-SITE=~A~C~C" |
|---|
| 121 | (request-uri url) #\Return #\Linefeed |
|---|
| 122 | host #\Return #\Linefeed |
|---|
| 123 | *cclan-mirror* #\Return #\Linefeed) |
|---|
| 124 | (when (and *proxy-passwd* *proxy-user*) |
|---|
| 125 | (format stream "Proxy-Authorization: Basic ~A~C~C" |
|---|
| 126 | (base64-encode (format nil "~A:~A" *proxy-user* *proxy-passwd*)) |
|---|
| 127 | #\Return #\Linefeed)) |
|---|
| 128 | (format stream "~C~C" #\Return #\Linefeed) |
|---|
| 129 | (force-output stream) |
|---|
| 130 | (list |
|---|
| 131 | (let* ((l (read-header-line stream)) |
|---|
| 132 | (space (position #\Space l))) |
|---|
| 133 | (parse-integer l :start (1+ space) :junk-allowed t)) |
|---|
| 134 | (loop for line = (read-header-line stream) |
|---|
| 135 | until (or (null line) |
|---|
| 136 | (zerop (length line)) |
|---|
| 137 | (eql (elt line 0) (code-char 13))) |
|---|
| 138 | collect |
|---|
| 139 | (let ((colon (position #\: line))) |
|---|
| 140 | (cons (intern (string-upcase (subseq line 0 colon)) :keyword) |
|---|
| 141 | (string-trim (list #\Space (code-char 13)) |
|---|
| 142 | (subseq line (1+ colon)))))) |
|---|
| 143 | stream))) |
|---|
| 144 | |
|---|
| 145 | (defun download-link-for-package (package-name-or-url) |
|---|
| 146 | (if (= (mismatch package-name-or-url "http://") 7) |
|---|
| 147 | package-name-or-url |
|---|
| 148 | (format nil "http://www.cliki.net/~A?download" |
|---|
| 149 | package-name-or-url))) |
|---|
| 150 | |
|---|
| 151 | (defun download-link-for-signature (url) |
|---|
| 152 | (concatenate 'string url ".asc")) |
|---|
| 153 | |
|---|
| 154 | ;;; XXX unsightful hack |
|---|
| 155 | (defvar *dont-check-signature* nil) |
|---|
| 156 | |
|---|
| 157 | (defun download-files-for-package (package-name-or-url) |
|---|
| 158 | (setf *dont-check-signature* nil) |
|---|
| 159 | (multiple-value-bind (package-url package-file) |
|---|
| 160 | (download-url-to-temporary-file |
|---|
| 161 | (download-link-for-package package-name-or-url)) |
|---|
| 162 | (if (verify-gpg-signatures-p package-name-or-url) |
|---|
| 163 | (restart-case |
|---|
| 164 | (multiple-value-bind (signature-url signature-file) |
|---|
| 165 | (download-url-to-temporary-file |
|---|
| 166 | (download-link-for-signature package-url)) |
|---|
| 167 | (declare (ignore signature-url)) |
|---|
| 168 | (values package-file signature-file)) |
|---|
| 169 | (skip-gpg-check () |
|---|
| 170 | :report "Don't check GPG signature for this package" |
|---|
| 171 | (progn |
|---|
| 172 | (setf *dont-check-signature* t) |
|---|
| 173 | (values package-file nil)))) |
|---|
| 174 | (values package-file nil)))) |
|---|
| 175 | |
|---|
| 176 | (defun verify-gpg-signature (file-name signature-name) |
|---|
| 177 | (block verify |
|---|
| 178 | (when (and (null signature-name) *dont-check-signature*) |
|---|
| 179 | (return-from verify t)) |
|---|
| 180 | (loop |
|---|
| 181 | (restart-case |
|---|
| 182 | (let ((tags (gpg-results file-name signature-name))) |
|---|
| 183 | ;; test that command returned something |
|---|
| 184 | (unless tags |
|---|
| 185 | (error 'gpg-shell-error)) |
|---|
| 186 | ;; test for obvious key/sig problems |
|---|
| 187 | (let ((errsig (header-value :errsig tags))) |
|---|
| 188 | (and errsig (error 'key-not-found :key-id errsig))) |
|---|
| 189 | (let ((badsig (header-value :badsig tags))) |
|---|
| 190 | (and badsig (error 'key-not-found :key-id badsig))) |
|---|
| 191 | (let* ((good (header-value :goodsig tags)) |
|---|
| 192 | (id (first good)) |
|---|
| 193 | (name (format nil "~{~A~^ ~}" (rest good)))) |
|---|
| 194 | ;; good signature, but perhaps not trusted |
|---|
| 195 | (restart-case |
|---|
| 196 | (let ((trusted? (or (header-pair :trust_ultimate tags) |
|---|
| 197 | (header-pair :trust_fully tags))) |
|---|
| 198 | (in-list? (assoc id *trusted-uids* :test #'equal))) |
|---|
| 199 | (cond ((or trusted? in-list?) |
|---|
| 200 | ;; ok |
|---|
| 201 | ) |
|---|
| 202 | ((not trusted?) |
|---|
| 203 | (error 'key-not-trusted |
|---|
| 204 | :key-user-name name :key-id id)) |
|---|
| 205 | ((not in-list?) |
|---|
| 206 | (error 'author-not-trusted |
|---|
| 207 | :key-user-name name :key-id id)))) |
|---|
| 208 | (add-key (&rest rest) |
|---|
| 209 | :report "Add to package supplier list" |
|---|
| 210 | (declare (ignore rest)) |
|---|
| 211 | (pushnew (list id name) *trusted-uids*)))) |
|---|
| 212 | (return-from verify t)) |
|---|
| 213 | (install-anyways |
|---|
| 214 | (&rest rest) |
|---|
| 215 | :report "Don't check GPG signature for this package" |
|---|
| 216 | (declare (ignore rest)) |
|---|
| 217 | (return-from verify t)) |
|---|
| 218 | (retry-gpg-check |
|---|
| 219 | (&rest args) |
|---|
| 220 | :report "Retry GPG check \(e.g., after downloading the key\)" |
|---|
| 221 | (declare (ignore args)) |
|---|
| 222 | nil))))) |
|---|
| 223 | |
|---|
| 224 | (defun header-value (name headers) |
|---|
| 225 | "Searchers headers for name _without_ case sensitivity. Headers should be an alist mapping symbols to values; name a symbol. Returns the value if name is found or nil if it is not." |
|---|
| 226 | (cdr (header-pair name headers))) |
|---|
| 227 | |
|---|
| 228 | (defun header-pair (name headers) |
|---|
| 229 | "Searchers headers for name _without_ case sensitivity. Headers should be an alist mapping symbols to values; name a symbol. Returns the \(name value\) pair if name is found or nil if it is not." |
|---|
| 230 | (assoc name headers |
|---|
| 231 | :test (lambda (a b) |
|---|
| 232 | (string-equal (symbol-name a) (symbol-name b))))) |
|---|
| 233 | |
|---|
| 234 | (defun validate-preferred-location () |
|---|
| 235 | (typecase *preferred-location* |
|---|
| 236 | (null t) |
|---|
| 237 | ((integer 0) |
|---|
| 238 | (assert (<= 1 *preferred-location* (length *locations*)) |
|---|
| 239 | (*preferred-location*) |
|---|
| 240 | 'invalid-preferred-location-number-error |
|---|
| 241 | :preferred-location *preferred-location*)) |
|---|
| 242 | ((or symbol string) |
|---|
| 243 | (assert (find *preferred-location* *locations* |
|---|
| 244 | :test (if (typep *preferred-location* 'symbol) |
|---|
| 245 | #'eq #'string-equal) :key #'third) |
|---|
| 246 | (*preferred-location*) |
|---|
| 247 | 'invalid-preferred-location-name-error |
|---|
| 248 | :preferred-location *preferred-location*)) |
|---|
| 249 | (t |
|---|
| 250 | (assert nil |
|---|
| 251 | (*preferred-location*) |
|---|
| 252 | 'invalid-preferred-location-error |
|---|
| 253 | :preferred-location *preferred-location*))) |
|---|
| 254 | *preferred-location*) |
|---|
| 255 | |
|---|
| 256 | (defun select-location () |
|---|
| 257 | (loop with n-locations = (length *locations*) |
|---|
| 258 | for response = (progn |
|---|
| 259 | (format t "Install where?~%") |
|---|
| 260 | (loop for (source system name) in *locations* |
|---|
| 261 | for i from 1 |
|---|
| 262 | do (format t "~A) ~A: ~% System in ~A~% Files in ~A ~%" |
|---|
| 263 | i name system source)) |
|---|
| 264 | (format t "0) Abort installation.~% --> ") |
|---|
| 265 | (force-output) |
|---|
| 266 | (read)) |
|---|
| 267 | when (and (numberp response) |
|---|
| 268 | (<= 1 response n-locations)) |
|---|
| 269 | return response |
|---|
| 270 | when (and (numberp response) |
|---|
| 271 | (zerop response)) |
|---|
| 272 | do (abort (make-condition 'installation-abort)))) |
|---|
| 273 | |
|---|
| 274 | (defun install-location () |
|---|
| 275 | (validate-preferred-location) |
|---|
| 276 | (let ((location-selection (or *preferred-location* |
|---|
| 277 | (select-location)))) |
|---|
| 278 | (etypecase location-selection |
|---|
| 279 | (integer |
|---|
| 280 | (elt *locations* (1- location-selection))) |
|---|
| 281 | ((or symbol string) |
|---|
| 282 | (find location-selection *locations* :key #'third |
|---|
| 283 | :test (if (typep location-selection 'string) |
|---|
| 284 | #'string-equal #'eq)))))) |
|---|
| 285 | |
|---|
| 286 | |
|---|
| 287 | ;;; install-package -- |
|---|
| 288 | |
|---|
| 289 | (defun find-shell-command (command) |
|---|
| 290 | (loop for directory in *shell-search-paths* do |
|---|
| 291 | (let ((target (make-pathname :name command :type nil |
|---|
| 292 | :directory directory))) |
|---|
| 293 | (when (probe-file target) |
|---|
| 294 | (return-from find-shell-command (namestring target))))) |
|---|
| 295 | (values nil)) |
|---|
| 296 | |
|---|
| 297 | (defun tar-command () |
|---|
| 298 | #-(or :win32 :mswindows) |
|---|
| 299 | (find-shell-command *gnu-tar-program*) |
|---|
| 300 | #+(or :win32 :mswindows) |
|---|
| 301 | *cygwin-bash-program*) |
|---|
| 302 | |
|---|
| 303 | (defun tar-arguments (source packagename) |
|---|
| 304 | #-(or :win32 :mswindows :scl) |
|---|
| 305 | (list "-C" (namestring (truename source)) |
|---|
| 306 | "-xzvf" (namestring (truename packagename))) |
|---|
| 307 | #+(or :win32 :mswindows) |
|---|
| 308 | (list "-l" |
|---|
| 309 | "-c" |
|---|
| 310 | (format nil "\"tar -C \\\"`cygpath '~A'`\\\" -xzvf \\\"`cygpath '~A'`\\\"\"" |
|---|
| 311 | (namestring (truename source)) |
|---|
| 312 | (namestring (truename packagename)))) |
|---|
| 313 | #+scl |
|---|
| 314 | (list "-C" (ext:unix-namestring (truename source)) |
|---|
| 315 | "-xzvf" (ext:unix-namestring (truename packagename)))) |
|---|
| 316 | |
|---|
| 317 | (defun extract-using-tar (to-dir tarball) |
|---|
| 318 | (let ((tar-command (tar-command))) |
|---|
| 319 | (if (and tar-command (probe-file tar-command)) |
|---|
| 320 | (return-output-from-program tar-command |
|---|
| 321 | (tar-arguments to-dir tarball)) |
|---|
| 322 | (warn "Cannot find tar command ~S." tar-command)))) |
|---|
| 323 | |
|---|
| 324 | (defun extract (to-dir tarball) |
|---|
| 325 | (or (some #'(lambda (extractor) (funcall extractor to-dir tarball)) |
|---|
| 326 | *tar-extractors*) |
|---|
| 327 | (error "Unable to extract tarball ~A." tarball))) |
|---|
| 328 | |
|---|
| 329 | (defun install-package (source system packagename) |
|---|
| 330 | "Returns a list of system names (ASDF or MK:DEFSYSTEM) for installed systems." |
|---|
| 331 | (ensure-directories-exist source) |
|---|
| 332 | (ensure-directories-exist system) |
|---|
| 333 | (let* ((tar (extract source packagename)) |
|---|
| 334 | ;; Some tar programs (OSX) list entries with preceeding "x " |
|---|
| 335 | ;; as in "x entry/file.asd" |
|---|
| 336 | (pos-begin (if (string= (subseq tar 0 2) "x ") |
|---|
| 337 | 2 |
|---|
| 338 | 0)) |
|---|
| 339 | (pos-slash (or (position #\/ tar) |
|---|
| 340 | (position #\Return tar) |
|---|
| 341 | (position #\Linefeed tar))) |
|---|
| 342 | (*default-pathname-defaults* |
|---|
| 343 | (merge-pathnames |
|---|
| 344 | (make-pathname :directory |
|---|
| 345 | `(:relative ,(subseq tar pos-begin pos-slash))) |
|---|
| 346 | source))) |
|---|
| 347 | (loop for sysfile in (append |
|---|
| 348 | (directory |
|---|
| 349 | (make-pathname :defaults *default-pathname-defaults* |
|---|
| 350 | :name :wild |
|---|
| 351 | :type "asd")) |
|---|
| 352 | (directory |
|---|
| 353 | (make-pathname :defaults *default-pathname-defaults* |
|---|
| 354 | :name :wild |
|---|
| 355 | :type "system"))) |
|---|
| 356 | do (maybe-symlink-sysfile system sysfile) |
|---|
| 357 | do (installer-msg t "Found system definition: ~A" sysfile) |
|---|
| 358 | do (maybe-update-central-registry sysfile) |
|---|
| 359 | collect sysfile))) |
|---|
| 360 | |
|---|
| 361 | (defun maybe-update-central-registry (sysfile) |
|---|
| 362 | ;; make sure that the systems we install are accessible in case |
|---|
| 363 | ;; asdf-install:*locations* and asdf:*central-registry* are out |
|---|
| 364 | ;; of sync |
|---|
| 365 | (add-registry-location sysfile)) |
|---|
| 366 | |
|---|
| 367 | (defun temp-file-name (p) |
|---|
| 368 | (declare (ignore p)) |
|---|
| 369 | (let ((pathname nil)) |
|---|
| 370 | (loop for i = 0 then (1+ i) do |
|---|
| 371 | (setf pathname |
|---|
| 372 | (merge-pathnames |
|---|
| 373 | (make-pathname |
|---|
| 374 | :name (format nil "asdf-install-~d" i) |
|---|
| 375 | :type "asdf-install-tmp") |
|---|
| 376 | *temporary-directory*)) |
|---|
| 377 | (unless (probe-file pathname) |
|---|
| 378 | (return-from temp-file-name pathname))))) |
|---|
| 379 | |
|---|
| 380 | |
|---|
| 381 | ;;; install |
|---|
| 382 | ;;; This is the external entry point. |
|---|
| 383 | |
|---|
| 384 | (defun install (packages &key (propagate nil) (where *preferred-location*)) |
|---|
| 385 | (let* ((*preferred-location* where) |
|---|
| 386 | (*temporary-files* nil) |
|---|
| 387 | (trusted-uid-file |
|---|
| 388 | (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*)) |
|---|
| 389 | (*trusted-uids* |
|---|
| 390 | (when (probe-file trusted-uid-file) |
|---|
| 391 | (with-open-file (f trusted-uid-file) (read f)))) |
|---|
| 392 | (old-uids (copy-list *trusted-uids*)) |
|---|
| 393 | #+asdf |
|---|
| 394 | (*defined-systems* (if propagate |
|---|
| 395 | (make-hash-table :test 'equal) |
|---|
| 396 | *defined-systems*)) |
|---|
| 397 | (packages (if (atom packages) (list packages) packages)) |
|---|
| 398 | (*propagate-installation* propagate) |
|---|
| 399 | (*systems-installed-this-time* nil)) |
|---|
| 400 | (unwind-protect |
|---|
| 401 | (destructuring-bind (source system name) (install-location) |
|---|
| 402 | (declare (ignore name)) |
|---|
| 403 | (labels |
|---|
| 404 | ((one-iter (packages) |
|---|
| 405 | (let ((packages-to-install nil)) |
|---|
| 406 | (loop for p in (mapcar #'string packages) do |
|---|
| 407 | (cond ((local-archive-p p) |
|---|
| 408 | (setf packages-to-install |
|---|
| 409 | (append packages-to-install |
|---|
| 410 | (install-package source system p)))) |
|---|
| 411 | (t |
|---|
| 412 | (multiple-value-bind (package signature) |
|---|
| 413 | (download-files-for-package p) |
|---|
| 414 | (when (verify-gpg-signatures-p p) |
|---|
| 415 | (verify-gpg-signature package signature)) |
|---|
| 416 | (installer-msg t "Installing ~A in ~A, ~A" |
|---|
| 417 | p source system) |
|---|
| 418 | (install-package source system package)) |
|---|
| 419 | (setf packages-to-install |
|---|
| 420 | (append packages-to-install |
|---|
| 421 | (list p)))))) |
|---|
| 422 | (dolist (package packages-to-install) |
|---|
| 423 | (setf package |
|---|
| 424 | (etypecase package |
|---|
| 425 | (symbol package) |
|---|
| 426 | (string (intern package :asdf-install)) |
|---|
| 427 | (pathname (intern |
|---|
| 428 | (namestring (pathname-name package)) |
|---|
| 429 | :asdf-install)))) |
|---|
| 430 | (handler-bind |
|---|
| 431 | ( |
|---|
| 432 | #+asdf |
|---|
| 433 | (asdf:missing-dependency |
|---|
| 434 | (lambda (c) |
|---|
| 435 | (installer-msg |
|---|
| 436 | t |
|---|
| 437 | "Downloading package ~A, required by ~A~%" |
|---|
| 438 | (asdf::missing-requires c) |
|---|
| 439 | (asdf:component-name |
|---|
| 440 | (asdf::missing-required-by c))) |
|---|
| 441 | (one-iter |
|---|
| 442 | (list (asdf::coerce-name |
|---|
| 443 | (asdf::missing-requires c)))) |
|---|
| 444 | (invoke-restart 'retry))) |
|---|
| 445 | #+mk-defsystem |
|---|
| 446 | (make:missing-component |
|---|
| 447 | (lambda (c) |
|---|
| 448 | (installer-msg |
|---|
| 449 | t |
|---|
| 450 | "Downloading package ~A, required by ~A~%" |
|---|
| 451 | (make:missing-component-name c) |
|---|
| 452 | package) |
|---|
| 453 | (one-iter (list (make:missing-component-name c))) |
|---|
| 454 | (invoke-restart 'retry)))) |
|---|
| 455 | (loop (multiple-value-bind (ret restart-p) |
|---|
| 456 | (with-simple-restart |
|---|
| 457 | (retry "Retry installation") |
|---|
| 458 | (push package *systems-installed-this-time*) |
|---|
| 459 | (load-package package)) |
|---|
| 460 | (declare (ignore ret)) |
|---|
| 461 | (unless restart-p (return))))))))) |
|---|
| 462 | (one-iter packages))) |
|---|
| 463 | ;;; cleanup |
|---|
| 464 | (unless (equal old-uids *trusted-uids*) |
|---|
| 465 | (let ((create-file-p nil)) |
|---|
| 466 | (unless (probe-file trusted-uid-file) |
|---|
| 467 | (installer-msg t "Trusted UID file ~A does not exist" |
|---|
| 468 | (namestring trusted-uid-file)) |
|---|
| 469 | (setf create-file-p |
|---|
| 470 | (y-or-n-p "Do you want to create the file?"))) |
|---|
| 471 | (when (or create-file-p (probe-file trusted-uid-file)) |
|---|
| 472 | (ensure-directories-exist trusted-uid-file) |
|---|
| 473 | (with-open-file (out trusted-uid-file |
|---|
| 474 | :direction :output |
|---|
| 475 | :if-exists :supersede) |
|---|
| 476 | (with-standard-io-syntax |
|---|
| 477 | (prin1 *trusted-uids* out)))))) |
|---|
| 478 | (dolist (l *temporary-files* t) |
|---|
| 479 | (when (probe-file l) (delete-file l)))) |
|---|
| 480 | (nreverse *systems-installed-this-time*))) |
|---|
| 481 | |
|---|
| 482 | (defun local-archive-p (package) |
|---|
| 483 | #+(or :sbcl :allegro) (probe-file package) |
|---|
| 484 | #-(or :sbcl :allegro) (and (/= (mismatch package "http://") 7) |
|---|
| 485 | (probe-file package))) |
|---|
| 486 | |
|---|
| 487 | (defun load-package (package) |
|---|
| 488 | #+asdf |
|---|
| 489 | (progn |
|---|
| 490 | (installer-msg t "Loading system ~S via ASDF." package) |
|---|
| 491 | (asdf:operate 'asdf:load-op package)) |
|---|
| 492 | #+mk-defsystem |
|---|
| 493 | (progn |
|---|
| 494 | (installer-msg t "Loading system ~S via MK:DEFSYSTEM." package) |
|---|
| 495 | (mk:load-system package))) |
|---|
| 496 | |
|---|
| 497 | ;;; uninstall -- |
|---|
| 498 | |
|---|
| 499 | (defun uninstall (system &optional (prompt t)) |
|---|
| 500 | #+asdf |
|---|
| 501 | (let* ((asd (asdf:system-definition-pathname system)) |
|---|
| 502 | (system (asdf:find-system system)) |
|---|
| 503 | (dir (pathname-sans-name+type |
|---|
| 504 | (asdf::resolve-symlinks asd)))) |
|---|
| 505 | (when (or (not prompt) |
|---|
| 506 | (y-or-n-p |
|---|
| 507 | "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?" |
|---|
| 508 | system asd dir)) |
|---|
| 509 | #-(or :win32 :mswindows) |
|---|
| 510 | (delete-file asd) |
|---|
| 511 | (let ((dir (#-scl namestring #+scl ext:unix-namestring (truename dir)))) |
|---|
| 512 | (when dir |
|---|
| 513 | (asdf:run-shell-command "rm -r '~A'" dir))))) |
|---|
| 514 | |
|---|
| 515 | #+mk-defsystem |
|---|
| 516 | (multiple-value-bind (sysfile sysfile-exists-p) |
|---|
| 517 | (mk:system-definition-pathname system) |
|---|
| 518 | (when sysfile-exists-p |
|---|
| 519 | (let ((system (ignore-errors (mk:find-system system :error)))) |
|---|
| 520 | (when system |
|---|
| 521 | (when (or (not prompt) |
|---|
| 522 | (y-or-n-p |
|---|
| 523 | "Delete system ~A.~%system file: ~A~%Are you sure?" |
|---|
| 524 | system |
|---|
| 525 | sysfile)) |
|---|
| 526 | (mk:clean-system system) |
|---|
| 527 | (delete-file sysfile) |
|---|
| 528 | (dolist (f (mk:files-in-system system)) |
|---|
| 529 | (delete-file f))) |
|---|
| 530 | )) |
|---|
| 531 | ))) |
|---|
| 532 | |
|---|
| 533 | |
|---|
| 534 | ;;; some day we will also do UPGRADE, but we need to sort out version |
|---|
| 535 | ;;; numbering a bit better first |
|---|
| 536 | |
|---|
| 537 | #+(and :asdf (or :win32 :mswindows)) |
|---|
| 538 | (defun sysdef-source-dir-search (system) |
|---|
| 539 | (let ((name (asdf::coerce-name system))) |
|---|
| 540 | (dolist (location *locations*) |
|---|
| 541 | (let* ((dir (first location)) |
|---|
| 542 | (files (directory (merge-pathnames |
|---|
| 543 | (make-pathname :name name |
|---|
| 544 | :type "asd" |
|---|
| 545 | :version :newest |
|---|
| 546 | :directory '(:relative :wild) |
|---|
| 547 | :host nil |
|---|
| 548 | :device nil) |
|---|
| 549 | dir)))) |
|---|
| 550 | (dolist (file files) |
|---|
| 551 | (when (probe-file file) |
|---|
| 552 | (return-from sysdef-source-dir-search file))))))) |
|---|
| 553 | |
|---|
| 554 | (defmethod asdf:find-component :around |
|---|
| 555 | ((module (eql nil)) name) |
|---|
| 556 | (when (or (not *propagate-installation*) |
|---|
| 557 | (member name *systems-installed-this-time* |
|---|
| 558 | :test (lambda (a b) |
|---|
| 559 | (flet ((ensure-string (x) |
|---|
| 560 | (etypecase x |
|---|
| 561 | (symbol (symbol-name x)) |
|---|
| 562 | (string x)))) |
|---|
| 563 | (string-equal (ensure-string a) (ensure-string b)))))) |
|---|
| 564 | (call-next-method))) |
|---|
| 565 | |
|---|
| 566 | (defun show-version-information () |
|---|
| 567 | (let ((version (asdf-install-version))) |
|---|
| 568 | (if version |
|---|
| 569 | (format *standard-output* "~&;;; ASDF-Install version ~A" |
|---|
| 570 | version) |
|---|
| 571 | (format *standard-output* "~&;;; ASDF-Install version unknown; unable to find ASDF system definition.")) |
|---|
| 572 | (values))) |
|---|
| 573 | |
|---|
| 574 | (defun asdf-install-version () |
|---|
| 575 | "Returns the ASDf-Install version information as a string or nil if it cannot be determined." |
|---|
| 576 | (let ((system (asdf:find-system 'asdf-install))) |
|---|
| 577 | (when system (asdf:component-version system)))) |
|---|
| 578 | |
|---|
| 579 | ;; load customizations if any |
|---|
| 580 | (eval-when (:load-toplevel :execute) |
|---|
| 581 | (let* ((*package* (find-package :asdf-install-customize)) |
|---|
| 582 | (file (probe-file (merge-pathnames |
|---|
| 583 | (make-pathname :name ".asdf-install") |
|---|
| 584 | (truename (user-homedir-pathname)))))) |
|---|
| 585 | (when file (load file)))) |
|---|
| 586 | |
|---|
| 587 | ;;; end of file -- install.lisp -- |
|---|
