Commit 7f4d19be authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Release 1.373. Remove tabs in all lisp files.

parent faa8b05b
...@@ -33,7 +33,7 @@ ...@@ -33,7 +33,7 @@
;; Note how we use OUTPUT-FILES to find the binary locations ;; Note how we use OUTPUT-FILES to find the binary locations
;; This allows the user to override the names. ;; This allows the user to override the names.
(let* ((input (output-files o c)) (let* ((input (output-files o c))
(output (compile-file-pathname (first input) :type :fasl))) (output (compile-file-pathname (first input) :type :fasl)))
(c:build-fasl output :lisp-files (remove "fas" input :key #'pathname-type :test #'string=)))) (c:build-fasl output :lisp-files (remove "fas" input :key #'pathname-type :test #'string=))))
(defmethod perform ((o load-op) (c cl-source-file)) (defmethod perform ((o load-op) (c cl-source-file))
...@@ -83,11 +83,11 @@ ...@@ -83,11 +83,11 @@
((type :initform :program))) ((type :initform :program)))
(defmethod initialize-instance :after ((instance bundle-op) &rest initargs (defmethod initialize-instance :after ((instance bundle-op) &rest initargs
&key (name-suffix nil name-suffix-p) &key (name-suffix nil name-suffix-p)
&allow-other-keys) &allow-other-keys)
(unless name-suffix-p (unless name-suffix-p
(setf (slot-value instance 'name-suffix) (setf (slot-value instance 'name-suffix)
(if (bundle-op-monolithic-p instance) "-mono" ""))) (if (bundle-op-monolithic-p instance) "-mono" "")))
(when (typep instance 'monolithic-bundle-op) (when (typep instance 'monolithic-bundle-op)
(destructuring-bind (&rest original-initargs (destructuring-bind (&rest original-initargs
&key prologue-code epilogue-code &allow-other-keys) &key prologue-code epilogue-code &allow-other-keys)
...@@ -97,8 +97,8 @@ ...@@ -97,8 +97,8 @@
(monolithic-op-prologue-code instance) prologue-code (monolithic-op-prologue-code instance) prologue-code
(monolithic-op-epilogue-code instance) epilogue-code))) (monolithic-op-epilogue-code instance) epilogue-code)))
(setf (bundle-op-build-args instance) (setf (bundle-op-build-args instance)
(remove-keys '(type monolithic name-suffix) (remove-keys '(type monolithic name-suffix)
(slot-value instance 'original-initargs)))) (slot-value instance 'original-initargs))))
(defvar *force-load-p* nil) (defvar *force-load-p* nil)
...@@ -114,12 +114,12 @@ ...@@ -114,12 +114,12 @@
(tree (traverse (make-instance 'load-op) system))) (tree (traverse (make-instance 'load-op) system)))
(append (append
(loop for (op . component) in tree (loop for (op . component) in tree
when (and (typep op 'load-op) when (and (typep op 'load-op)
(typep component filter-type) (typep component filter-type)
(or (not filter-system) (eq (component-system component) filter-system))) (or (not filter-system) (eq (component-system component) filter-system)))
collect (progn collect (progn
(when (eq component system) (setf include-self nil)) (when (eq component system) (setf include-self nil))
(cons operation component))) (cons operation component)))
(and include-self (list (cons operation system)))))) (and include-self (list (cons operation system))))))
;;; ;;;
...@@ -150,8 +150,8 @@ ...@@ -150,8 +150,8 @@
;;; ;;;
(defmethod bundle-sub-operations ((o lib-op) c) (defmethod bundle-sub-operations ((o lib-op) c)
(gather-components 'compile-op c (gather-components 'compile-op c
:filter-system (and (not (bundle-op-monolithic-p o)) c) :filter-system (and (not (bundle-op-monolithic-p o)) c)
:filter-type '(not system))) :filter-type '(not system)))
;;; ;;;
;;; SHARED LIBRARIES ;;; SHARED LIBRARIES
;;; ;;;
...@@ -173,7 +173,7 @@ ...@@ -173,7 +173,7 @@
(loop for (op . dep) in (bundle-sub-operations o c) (loop for (op . dep) in (bundle-sub-operations o c)
when (typep dep 'system) when (typep dep 'system)
collect (list (class-name (class-of op)) collect (list (class-name (class-of op))
(component-name dep)))) (component-name dep))))
(defmethod component-depends-on ((o lib-op) (c system)) (defmethod component-depends-on ((o lib-op) (c system))
(list (list 'compile-op (component-name c)))) (list (list 'compile-op (component-name c))))
...@@ -187,9 +187,9 @@ ...@@ -187,9 +187,9 @@
(defmethod output-files ((o bundle-op) (c system)) (defmethod output-files ((o bundle-op) (c system))
(let ((name (concatenate 'base-string (component-name c) (let ((name (concatenate 'base-string (component-name c)
(slot-value o 'name-suffix)))) (slot-value o 'name-suffix))))
(list (merge-pathnames (compile-file-pathname name :type (bundle-op-type o)) (list (merge-pathnames (compile-file-pathname name :type (bundle-op-type o))
(component-relative-pathname c))))) (component-relative-pathname c)))))
(defmethod output-files ((o fasl-op) (c system)) (defmethod output-files ((o fasl-op) (c system))
(loop for file in (call-next-method) (loop for file in (call-next-method)
...@@ -203,10 +203,10 @@ ...@@ -203,10 +203,10 @@
(defmethod perform ((o bundle-op) (c system)) (defmethod perform ((o bundle-op) (c system))
(let* ((object-files (remove "fas" (input-files o c) :key #'pathname-type :test #'string=)) (let* ((object-files (remove "fas" (input-files o c) :key #'pathname-type :test #'string=))
(output (output-files o c))) (output (output-files o c)))
(ensure-directories-exist (first output)) (ensure-directories-exist (first output))
(apply #'c::builder (bundle-op-type o) (first output) :lisp-files object-files (apply #'c::builder (bundle-op-type o) (first output) :lisp-files object-files
(append (bundle-op-build-args o) (append (bundle-op-build-args o)
(when (and (typep o 'monolithic-bundle-op) (when (and (typep o 'monolithic-bundle-op)
(monolithic-op-prologue-code o)) (monolithic-op-prologue-code o))
`(:prologue-code ,(monolithic-op-prologue-code o))) `(:prologue-code ,(monolithic-op-prologue-code o)))
...@@ -229,8 +229,8 @@ ...@@ -229,8 +229,8 @@
(defun make-build (system &rest args &key (monolithic nil) (type :fasl) (defun make-build (system &rest args &key (monolithic nil) (type :fasl)
&allow-other-keys) &allow-other-keys)
(apply #'operate (select-operation monolithic type) (apply #'operate (select-operation monolithic type)
system system
(remove-keys '(monolithic type) args))) (remove-keys '(monolithic type) args)))
;;; ;;;
;;; LOAD-FASL-OP ;;; LOAD-FASL-OP
......
...@@ -40,7 +40,7 @@ an immediate concern ...@@ -40,7 +40,7 @@ an immediate concern
(defpackage :asdf-install (defpackage :asdf-install
(:use "CL" "SB-EXT" "SB-BSD-SOCKETS") (:use "CL" "SB-EXT" "SB-BSD-SOCKETS")
(:export #:*proxy* #:*cclan-mirror* #:*sbcl-home* (:export #:*proxy* #:*cclan-mirror* #:*sbcl-home*
#:*verify-gpg-signatures* #:*locations*)) #:*verify-gpg-signatures* #:*locations*))
(defpackage :asdf-install-customize (defpackage :asdf-install-customize
(:use "CL" "SB-EXT" "SB-BSD-SOCKETS" "ASDF-INSTALL")) (:use "CL" "SB-EXT" "SB-BSD-SOCKETS" "ASDF-INSTALL"))
...@@ -57,16 +57,16 @@ an immediate concern ...@@ -57,16 +57,16 @@ an immediate concern
;; want a directory ;; want a directory
(let ((path (pathname name))) (let ((path (pathname name)))
(if (pathname-name path) (if (pathname-name path)
(merge-pathnames (merge-pathnames
(make-pathname :directory `(:relative ,(pathname-name path)) (make-pathname :directory `(:relative ,(pathname-name path))
:name "") :name "")
path) path)
path))) path)))
(defvar *sbcl-home* (directorify (posix-getenv "SBCL_HOME"))) (defvar *sbcl-home* (directorify (posix-getenv "SBCL_HOME")))
(defvar *dot-sbcl* (defvar *dot-sbcl*
(merge-pathnames (make-pathname :directory '(:relative ".sbcl")) (merge-pathnames (make-pathname :directory '(:relative ".sbcl"))
(user-homedir-pathname))) (user-homedir-pathname)))
(defvar *verify-gpg-signatures* t) (defvar *verify-gpg-signatures* t)
...@@ -80,28 +80,28 @@ an immediate concern ...@@ -80,28 +80,28 @@ an immediate concern
(let* ((*package* (find-package :asdf-install-customize)) (let* ((*package* (find-package :asdf-install-customize))
(file (probe-file (merge-pathnames (file (probe-file (merge-pathnames
(make-pathname :name ".asdf-install") (make-pathname :name ".asdf-install")
(user-homedir-pathname))))) (user-homedir-pathname)))))
(when file (load file))) (when file (load file)))
(define-condition download-error (error) (define-condition download-error (error)
((url :initarg :url :reader download-url) ((url :initarg :url :reader download-url)
(response :initarg :response :reader download-response)) (response :initarg :response :reader download-response))
(:report (lambda (c s) (:report (lambda (c s)
(format s "Server responded ~A for GET ~A" (format s "Server responded ~A for GET ~A"
(download-response c) (download-url c))))) (download-response c) (download-url c)))))
(define-condition signature-error (error) (define-condition signature-error (error)
((cause :initarg :cause :reader signature-error-cause)) ((cause :initarg :cause :reader signature-error-cause))
(:report (lambda (c s) (:report (lambda (c s)
(format s "Cannot verify package signature: ~A" (format s "Cannot verify package signature: ~A"
(signature-error-cause c))))) (signature-error-cause c)))))
(defun url-host (url) (defun url-host (url)
(assert (string-equal url "http://" :end1 7)) (assert (string-equal url "http://" :end1 7))
(let* ((port-start (position #\: url :start 7)) (let* ((port-start (position #\: url :start 7))
(host-end (min (or (position #\/ url :start 7) (length url)) (host-end (min (or (position #\/ url :start 7) (length url))
(or port-start (length url))))) (or port-start (length url)))))
(subseq url 7 host-end))) (subseq url 7 host-end)))
(defun url-port (url) (defun url-port (url)
...@@ -111,8 +111,8 @@ an immediate concern ...@@ -111,8 +111,8 @@ an immediate concern
(defun url-connection (url) (defun url-connection (url)
(let ((s (make-instance 'inet-socket :type :stream :protocol :tcp)) (let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))
(host (url-host url)) (host (url-host url))
(port (url-port url))) (port (url-port url)))
(socket-connect (socket-connect
s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url))))) s (car (host-ent-addresses (get-host-by-name (url-host (or *proxy* url)))))
(url-port (or *proxy* url))) (url-port (or *proxy* url)))
...@@ -120,90 +120,90 @@ an immediate concern ...@@ -120,90 +120,90 @@ an immediate concern
;; we are exceedingly unportable about proper line-endings here. ;; we are exceedingly unportable about proper line-endings here.
;; Anyone wishing to run this under non-SBCL should take especial care ;; 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~%~%" (format stream "GET ~A HTTP/1.0~%Host: ~A~%Cookie: CCLAN-SITE=~A~%~%"
url host *cclan-mirror*) url host *cclan-mirror*)
(force-output stream) (force-output stream)
(list (list
(let* ((l (read-line stream)) (let* ((l (read-line stream))
(space (position #\Space l))) (space (position #\Space l)))
(parse-integer l :start (1+ space) :junk-allowed t)) (parse-integer l :start (1+ space) :junk-allowed t))
(loop for line = (read-line stream nil nil) (loop for line = (read-line stream nil nil)
until (or (null line) (eql (elt line 0) (code-char 13))) until (or (null line) (eql (elt line 0) (code-char 13)))
collect collect
(let ((colon (position #\: line))) (let ((colon (position #\: line)))
(cons (intern (string-upcase (subseq line 0 colon)) :keyword) (cons (intern (string-upcase (subseq line 0 colon)) :keyword)
(string-trim (list #\Space (code-char 13)) (string-trim (list #\Space (code-char 13))
(subseq line (1+ colon)))))) (subseq line (1+ colon))))))
stream)))) stream))))
(defun download (package-name-or-url file-name) (defun download (package-name-or-url file-name)
(let ((url (let ((url
(if (= (mismatch package-name-or-url "http://") 7) (if (= (mismatch package-name-or-url "http://") 7)
package-name-or-url package-name-or-url
(format nil "http://www.cliki.net/~A?download" (format nil "http://www.cliki.net/~A?download"
package-name-or-url)))) package-name-or-url))))
(destructuring-bind (response headers stream) (destructuring-bind (response headers stream)
(block got (block got
(loop (loop
(destructuring-bind (response headers stream) (url-connection url) (destructuring-bind (response headers stream) (url-connection url)
(unless (member response '(301 302)) (unless (member response '(301 302))
(return-from got (list response headers stream))) (return-from got (list response headers stream)))
(close stream) (close stream)
(setf url (cdr (assoc :location headers)))))) (setf url (cdr (assoc :location headers))))))
(if (>= response 400) (if (>= response 400)
(error 'download-error :url url :response response)) (error 'download-error :url url :response response))
(let ((length (parse-integer (let ((length (parse-integer
(or (cdr (assoc :content-length headers)) "") (or (cdr (assoc :content-length headers)) "")
:junk-allowed t))) :junk-allowed t)))
(format t "Downloading ~A bytes from ~A ..." (format t "Downloading ~A bytes from ~A ..."
(if length length "some unknown number of") url) (if length length "some unknown number of") url)
(force-output) (force-output)
(with-open-file (o file-name :direction :output) (with-open-file (o file-name :direction :output)
(if length (if length
(let ((buf (make-array length (let ((buf (make-array length
:element-type :element-type
(stream-element-type stream) ))) (stream-element-type stream) )))
(read-sequence buf stream) (read-sequence buf stream)
(write-sequence buf o)) (write-sequence buf o))
(sb-executable:copy-stream stream o)))) (sb-executable:copy-stream stream o))))
(close stream) (close stream)
(terpri) (terpri)
;; seems to have worked. let's try for a detached gpg signature too ;; seems to have worked. let's try for a detached gpg signature too
(when *verify-gpg-signatures* (when *verify-gpg-signatures*
(verify-gpg-signature url file-name))))) (verify-gpg-signature url file-name)))))
(defun verify-gpg-signature (url file-name) (defun verify-gpg-signature (url file-name)
(destructuring-bind (response headers stream) (destructuring-bind (response headers stream)
(url-connection (concatenate 'string url ".asc")) (url-connection (concatenate 'string url ".asc"))
(declare (ignore headers)) (declare (ignore headers))
(unwind-protect (unwind-protect
(if (= response 200) (if (= response 200)
;; sadly, we can't pass the stream directly to run-program, ;; sadly, we can't pass the stream directly to run-program,
;; because (at least in sbcl 0.8) that ignores existing buffered ;; because (at least in sbcl 0.8) that ignores existing buffered
;; data and only reads new fresh data direct from the file ;; data and only reads new fresh data direct from the file
;; descriptor ;; descriptor
(let ((data (make-string (parse-integer (let ((data (make-string (parse-integer
(cdr (assoc :content-length headers)) (cdr (assoc :content-length headers))
:junk-allowed t)))) :junk-allowed t))))
(read-sequence data stream) (read-sequence data stream)
(let ((ret (let ((ret
(process-exit-code (process-exit-code
(sb-ext:run-program "/usr/bin/gpg" (sb-ext:run-program "/usr/bin/gpg"
(list "--verify" "-" (list "--verify" "-"
(namestring file-name)) (namestring file-name))
:output t :output t
:input (make-string-input-stream data) :input (make-string-input-stream data)
:wait t)))) :wait t))))
(unless (zerop ret) (unless (zerop ret)
(error 'signature-error (error 'signature-error
:cause (make-condition :cause (make-condition
'simple-error 'simple-error
:format-control "GPG returned exit status ~A" :format-control "GPG returned exit status ~A"
:format-arguments (list ret)))))) :format-arguments (list ret))))))
(error 'signature-error (error 'signature-error
:cause :cause
(make-condition (make-condition
'download-error :url (concatenate 'string url ".asc") 'download-error :url (concatenate 'string url ".asc")
:response response))) :response response)))
(close stream)))) (close stream))))
...@@ -212,9 +212,9 @@ an immediate concern ...@@ -212,9 +212,9 @@ an immediate concern
(defun where () (defun where ()
(format t "Install where?~%") (format t "Install where?~%")
(loop for (source system name) in *locations* (loop for (source system name) in *locations*
for i from 1 for i from 1
do (format t "~A) ~A: ~% System in ~A~% Files in ~A ~%" do (format t "~A) ~A: ~% System in ~A~% Files in ~A ~%"
i name system source)) i name system source))
(format t " --> ") (force-output) (format t " --> ") (force-output)
(let ((response (read))) (let ((response (read)))
(when (> response 0) (when (> response 0)
...@@ -225,36 +225,36 @@ an immediate concern ...@@ -225,36 +225,36 @@ an immediate concern
(ensure-directories-exist source ) (ensure-directories-exist source )
(ensure-directories-exist system ) (ensure-directories-exist system )
(let* ((tar (let* ((tar
(with-output-to-string (o) (with-output-to-string (o)
(or (or
(sb-ext:run-program "/bin/tar" (sb-ext:run-program "/bin/tar"
(list "-C" (namestring source) (list "-C" (namestring source)
"-xzvf" (namestring packagename)) "-xzvf" (namestring packagename))
:output o :output o
:wait t) :wait t)
(error "can't untar")))) (error "can't untar"))))
(dummy (princ tar)) (dummy (princ tar))
(pos-slash (position #\/ tar)) (pos-slash (position #\/ tar))
(*default-pathname-defaults* (*default-pathname-defaults*
(merge-pathnames (merge-pathnames
(make-pathname :directory (make-pathname :directory
`(:relative ,(subseq tar 0 pos-slash))) `(:relative ,(subseq tar 0 pos-slash)))
source))) source)))
(loop for asd in (directory (loop for asd in (directory
(make-pathname :name :wild :type "asd")) (make-pathname :name :wild :type "asd"))
do (let ((target (merge-pathnames do (let ((target (merge-pathnames
(make-pathname :name (pathname-name asd) (make-pathname :name (pathname-name asd)
:type (pathname-type asd)) :type (pathname-type asd))
system))) system)))
(when (probe-file target) (when (probe-file target)
(sb-posix:unlink target)) (sb-posix:unlink target))
(sb-posix:symlink asd target)) (sb-posix:symlink asd target))
collect (pathname-name asd)))) collect (pathname-name asd))))
(defvar *temporary-files*) (defvar *temporary-files*)
(defun temp-file-name (p) (defun temp-file-name (p)
(let* ((pos-slash (position #\/ p :from-end t)) (let* ((pos-slash (position #\/ p :from-end t))
(pos-dot (position #\. p :start (or pos-slash 0)))) (pos-dot (position #\. p :start (or pos-slash 0))))
(merge-pathnames (merge-pathnames
(make-pathname (make-pathname
:name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot) :name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot)
...@@ -265,32 +265,32 @@ an immediate concern ...@@ -265,32 +265,32 @@ an immediate concern
(defun run (&optional (packages (cdr *posix-argv*))) (defun run (&optional (packages (cdr *posix-argv*)))
(destructuring-bind (source system name) (where) (destructuring-bind (source system name) (where)
(labels ((one-iter (packages) (labels ((one-iter (packages)
(dolist (asd (dolist (asd
(loop for p in packages (loop for p in packages
unless (probe-file p) unless (probe-file p)
do (let ((tmp (temp-file-name p))) do (let ((tmp (temp-file-name p)))
(pushnew tmp *temporary-files*) (pushnew tmp *temporary-files*)
(download p tmp) (download p tmp)
(setf p tmp)) (setf p tmp))
end end
do (format t "Installing ~A in ~A,~A~%" p source system) do (format t "Installing ~A in ~A,~A~%" p source system)
append (install source system p))) append (install source system p)))
(handler-case (handler-case
(asdf:operate 'asdf:load-op asd) (asdf:operate 'asdf:load-op asd)
(asdf:missing-dependency (c) (asdf:missing-dependency (c)
(format t "Downloading package ~A, required by ~A~%" (format t "Downloading package ~A, required by ~A~%"
(asdf::missing-requires c) (asdf::missing-requires c)
(asdf:component-name (asdf::missing-required-by c))) (asdf:component-name (asdf::missing-required-by c)))
(one-iter (list (one-iter (list
(symbol-name (asdf::missing-requires c))))))))) (symbol-name (asdf::missing-requires c)))))))))
(one-iter packages)))) (one-iter packages))))
(handler-case (handler-case
(let ((*temporary-files* nil)) (let ((*temporary-files* nil))
(unwind-protect (unwind-protect
(run) (run)
(dolist (l *temporary-files*) (dolist (l *temporary-files*)
(when (probe-file l) (delete-file l))))) (when (probe-file l) (delete-file l)))))
(error (c) (error (c)
(princ "Install failed due to error:") (terpri) (princ "Install failed due to error:") (terpri)
(princ c) (terpri) (princ c) (terpri)
......
...@@ -163,7 +163,7 @@ ...@@ -163,7 +163,7 @@
;;;; ;;;;
(defvar *asdf-revision* (defvar *asdf-revision*
;; the 1+ hair is to ensure that we don't do an inadvertent find and replace ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
(subseq "REVISION:1.372" (1+ (length "REVISION")))) (subseq "REVISION:1.373" (1+ (length "REVISION"))))
(defvar *resolve-symlinks* t (defvar *resolve-symlinks* t
"Determine whether or not ASDF resolves symlinks when defining systems. "Determine whether or not ASDF resolves symlinks when defining systems.
......
...@@ -418,19 +418,19 @@ slightly convoluted example: ...@@ -418,19 +418,19 @@ slightly convoluted example:
The method-form tokens need explaining: essentially, this part: The method-form tokens need explaining: essentially, this part:
@lisp @lisp
:perform (compile-op :after (op c) :perform (compile-op :after (op c)
(do-something c)) (do-something c))
:explain (compile-op :after (op c) :explain (compile-op :after (op c)
(explain-something c)) (explain-something c))
@end lisp @end lisp
has the effect of has the effect of
@lisp @lisp
(defmethod perform :after ((op compile-op) (c (eql ...))) (defmethod perform :after ((op compile-op) (c (eql ...)))
(do-something c)) (do-something c))
(defmethod explain :after ((op compile-op) (c (eql ...))) (defmethod explain :after ((op compile-op) (c (eql ...)))
(explain-something c)) (explain-something c))
@end lisp @end lisp
where @code{...} is