(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")))
,(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)
(defun copy-stream (in out)
- (let ((buf (make-array 8192 :element-type (stream-element-type in))))
+ (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))))
(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)))
(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 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