X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fasdf-install%2Finstaller.lisp;h=5d76644a168e5f5f1a25a8b17ec2388f74192dd3;hb=19e30f1008c2d03024e427d209e1cd38fd7e86af;hp=3672523fdba6cc57fbb1de1bb6a2ab2b47b13761;hpb=7f55cdab81d65acd8e7a4acf0f614b4b25f866fd;p=sbcl.git diff --git a/contrib/asdf-install/installer.lisp b/contrib/asdf-install/installer.lisp index 3672523..5d76644 100644 --- a/contrib/asdf-install/installer.lisp +++ b/contrib/asdf-install/installer.lisp @@ -2,8 +2,9 @@ (defvar *proxy* (posix-getenv "http_proxy")) (defvar *cclan-mirror* - (or (posix-getenv "CCLAN_MIRROR") - "http://ftp.linux.org.uk/pub/lisp/cclan/")) + (let ((mirror (posix-getenv "CCLAN_MIRROR"))) + (or (and (not (string= mirror "")) mirror) + "http://ftp.linux.org.uk/pub/lisp/cclan/"))) (defun directorify (name) ;; input name may or may not have a training #\/, but we know we @@ -13,7 +14,8 @@ (merge-pathnames (make-pathname :directory `(:relative ,(pathname-name path))) (make-pathname :directory (pathname-directory path) - :host (pathname-host path))) + :host (pathname-host path) + :device (pathname-device path))) path))) (defvar *sbcl-home* (directorify (posix-getenv "SBCL_HOME"))) @@ -23,19 +25,6 @@ (defparameter *trusted-uids* nil) - -(defun verify-gpg-signatures-p (url) - (labels ((prefixp (prefix string) - (let ((m (mismatch prefix string))) - (or (not m) (>= m (length prefix)))))) - (case *verify-gpg-signatures* - (nil nil) - (:unknown-locations - (notany - (lambda (x) (prefixp x url)) - (cons *cclan-mirror* *safe-url-prefixes*))) - (t t)))) - (defvar *locations* `((,(merge-pathnames "site/" *sbcl-home*) ,(merge-pathnames "site-systems/" *sbcl-home*) @@ -44,11 +33,13 @@ ,(merge-pathnames "systems/" *dot-sbcl*) "Personal installation"))) -(let* ((*package* (find-package :asdf-install-customize)) - (file (probe-file (merge-pathnames - (make-pathname :name ".asdf-install") - (user-homedir-pathname))))) - (when file (load file))) +(unless (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB") + ;; Not during build, thanks. + (let* ((*package* (find-package :asdf-install-customize)) + (file (probe-file (merge-pathnames + (make-pathname :name ".asdf-install") + (user-homedir-pathname))))) + (when file (load file)))) (define-condition download-error (error) ((url :initarg :url :reader download-url) @@ -66,7 +57,7 @@ (define-condition gpg-error (error) ((message :initarg :message :reader gpg-error-message)) (:report (lambda (c s) - (format t "GPG failed with error status:~%~S" + (format s "GPG failed with error status:~%~S" (gpg-error-message c))))) (define-condition no-signature (gpg-error) ()) @@ -119,7 +110,8 @@ (socket-connect s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url))))) (url-port (or *proxy* url))) - (let ((stream (socket-make-stream s :input t :output t :buffering :full :external-format :iso-8859-1))) + (let ((stream (socket-make-stream s :input t :output t :buffering :full + :element-type :default :external-format :iso-8859-1))) ;; we are exceedingly unportable about proper line-endings here. ;; Anyone wishing to run this under non-SBCL should take especial care (format stream "GET ~A HTTP/1.0~c~%~ @@ -146,6 +138,13 @@ (socket-open-p s)) (socket-close s))))) + +(defun copy-stream (in out) + (let ((buf (make-array 8192 :element-type (stream-element-type out)))) + (loop for pos = (read-sequence buf in) + until (zerop pos) + do (write-sequence buf out :end pos)))) + (defun download-files-for-package (package-name-or-url file-name) (let ((url (if (= (mismatch package-name-or-url "http://") 7) @@ -168,25 +167,24 @@ (format t "Downloading ~A bytes from ~A ..." (if length length "some unknown number of") url) (force-output) - (with-open-file (o file-name :direction :output :external-format :iso-8859-1) + (with-open-file (out file-name :direction :output + :element-type '(unsigned-byte 8)) (if length - (let ((buf (make-array length - :element-type - (stream-element-type stream)))) + (let ((buf (make-array length :element-type '(unsigned-byte 8)))) (read-sequence buf stream) - (write-sequence buf o)) - (sb-executable:copy-stream stream o)))) + (write-sequence buf out)) + (copy-stream stream out)))) (close stream) (terpri) (restart-case (verify-gpg-signature/url url file-name) - (skip-gpg-check (&rest rest) + (skip-gpg-check () :report "Don't check GPG signature for this package" nil))))) (defun read-until-eof (stream) (with-output-to-string (o) - (sb-executable:copy-stream stream o))) + (copy-stream stream o))) (defun verify-gpg-signature/string (string file-name) (let* ((proc @@ -197,13 +195,13 @@ (namestring file-name)) :output :stream :error :stream :search t :input (make-string-input-stream string) :wait t)) - (ret (process-exit-code proc)) (err (read-until-eof (process-error proc))) tags) (loop for l = (read-line (process-output proc) nil nil) while l when (> (mismatch l "[GNUPG:]") 6) - do (destructuring-bind (_ tag &rest data) (asdf::split l) + do (destructuring-bind (_ tag &rest data) (asdf::split-string l) + (declare (ignore _)) (pushnew (cons (intern tag :keyword) data) tags))) ;; test for obvious key/sig problems @@ -228,7 +226,7 @@ (error 'author-not-trusted :key-user-name name :key-id id :gpg-err nil)) - (add-key (&rest rest) + (add-key () :report "Add to package supplier list" (pushnew (list id name) *trusted-uids*))) (return)))))) @@ -260,29 +258,50 @@ (when (> response 0) (elt *locations* (1- response))))) +(defparameter *tar-program* + ;; Please do not "clean this up" by using a bunch of #+'s and one + ;; #-. When the conditional is written this way, adding a new + ;; special case only involves one change. If #- is used, two changes + ;; are needed. -- JES, 2007-02-12 + (progn + "tar" + #+darwin "gnutar" + #+(or sunos netbsd) "gtar")) + +(defun get-tar-directory (packagename) + (let* ((tar (with-output-to-string (o) + (or + (sb-ext:run-program *tar-program* + (list "-tzf" (namestring packagename)) + :output o + :search t + :wait t) + (error "can't list archive")))) + (first-line (subseq tar 0 (position #\newline tar)))) + (if (find #\/ first-line) + (subseq first-line 0 (position #\/ first-line)) + first-line))) + +(defun untar-package (source packagename) + (with-output-to-string (o) + (or + (sb-ext:run-program *tar-program* + (list "-C" (namestring source) + "-xzvf" (namestring packagename)) + :output o + :search t + :wait t) + (error "can't untar")))) + (defun install-package (source system packagename) "Returns a list of asdf system names for installed asdf systems" - (ensure-directories-exist source ) - (ensure-directories-exist system ) - (let* ((tar - (with-output-to-string (o) - (or - (sb-ext:run-program #-darwin "tar" - #+darwin "gnutar" - (list "-C" (namestring source) - "-xzvf" (namestring packagename)) - :output o - :search t - :wait t) - (error "can't untar")))) - (dummy (princ tar)) - (pos-slash (position #\/ tar)) + (ensure-directories-exist source) + (ensure-directories-exist system) + (let* ((tdir (get-tar-directory packagename)) (*default-pathname-defaults* - (merge-pathnames - (make-pathname :directory - `(:relative ,(subseq tar 0 pos-slash))) - source))) - (declare (ignore dummy)) + (merge-pathnames (make-pathname :directory `(:relative ,tdir)) + source))) + (princ (untar-package source packagename)) (loop for asd in (directory (make-pathname :name :wild :type "asd")) do (let ((target (merge-pathnames @@ -291,6 +310,7 @@ system))) (when (probe-file target) (sb-posix:unlink target)) + #-win32 (sb-posix:symlink asd target)) collect (pathname-name asd)))) @@ -313,6 +333,7 @@ (with-open-file (f p) (read f)))))) (unwind-protect (destructuring-bind (source system name) (where) + (declare (ignore name)) (labels ((one-iter (packages) (dolist (asd (loop for p in (mapcar 'string packages) @@ -342,6 +363,7 @@ (with-simple-restart (retry "Retry installation") (asdf:operate 'asdf:load-op asd)) + (declare (ignore ret)) (unless restart-p (return)))))))) (one-iter packages))) (let ((p (merge-pathnames "trusted-uids.lisp" *dot-sbcl*)))