(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
(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")))
(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*)
,(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)
(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) ())
(let ((port-start (position #\: url :start 7)))
(if port-start (parse-integer url :start (1+ port-start) :junk-allowed t) 80)))
+(defun request-uri (url)
+ (assert (string-equal url "http://" :end1 7))
+ (if *proxy*
+ url
+ (let ((path-start (position #\/ url :start 7)))
+ (subseq url path-start))))
+
(defun url-connection (url)
(let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))
(host (url-host url))
- (port (url-port url)))
+ (port (url-port url))
+ result)
(declare (ignore port))
- (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)))
- ;; 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~%Host: ~A~%Cookie: CCLAN-SITE=~A~%~%"
- url host *cclan-mirror*)
- (force-output stream)
- (list
- (let* ((l (read-line stream))
- (space (position #\Space l)))
- (parse-integer l :start (1+ space) :junk-allowed t))
- (loop for line = (read-line stream nil nil)
- until (or (null line) (eql (elt line 0) (code-char 13)))
- collect
- (let ((colon (position #\: line)))
- (cons (intern (string-upcase (subseq line 0 colon)) :keyword)
- (string-trim (list #\Space (code-char 13))
- (subseq line (1+ colon))))))
- stream))))
+ (unwind-protect
+ (progn
+ (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
+ :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~%~
+ Host: ~A~c~%~
+ Cookie: CCLAN-SITE=~A~c~%~c~%"
+ (request-uri url) #\Return
+ host #\Return
+ *cclan-mirror* #\Return #\Return)
+ (force-output stream)
+ (setf result
+ (list
+ (let* ((l (read-line stream))
+ (space (position #\Space l)))
+ (parse-integer l :start (1+ space) :junk-allowed t))
+ (loop for line = (read-line stream nil nil)
+ until (or (null line) (eql (elt line 0) (code-char 13)))
+ collect
+ (let ((colon (position #\: line)))
+ (cons (intern (string-upcase (subseq line 0 colon)) :keyword)
+ (string-trim (list #\Space (code-char 13))
+ (subseq line (1+ colon))))))
+ stream))))
+ (when (and (null result)
+ (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
(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
(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
(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))))))
(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
system)))
(when (probe-file target)
(sb-posix:unlink target))
+ #-win32
(sb-posix:symlink asd target))
collect (pathname-name asd))))
(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)
(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*)))
projects / sbcl.git / blobdiff