Skip to content
Snippets Groups Projects
Commit 0be82da2 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

Merge branch 'upstream'

parents 4149709d ae82047e
No related branches found
No related tags found
No related merge requests found
Showing with 1420 additions and 1286 deletions
# really this is private to my build process # really this is private to my build process
make/
common-lisp.net
.vcs
init-lisp.lisp
website/changelog.xml
push push
resbcl resbcl
reccl reccl
reecl
regcl
# Temporary files from documentation build # Temporary files from documentation build
doc/asdf/ doc/asdf/
...@@ -26,17 +23,18 @@ doc/asdf.tp ...@@ -26,17 +23,18 @@ doc/asdf.tp
doc/asdf.vr doc/asdf.vr
doc/asdf.vrs doc/asdf.vrs
# We build these at various stages in the make process # We build these at various stages in the build and test process
LICENSE LICENSE
website/output/
tmp/ tmp/
lift-local.config
*.dribble *.dribble
*.fasl *.fasl
*.dfsl *.dfsl
*.cfsl *.cfsl
*.fas *.fas
*.lib *.lib
*.o *.[oahcisS]
*.*fsl *.*fsl
*.bak *.bak
*.data
test/try-reloading-dependency.asd
test/fileMissing.lisp
...@@ -7,11 +7,12 @@ clnet_home := "/project/asdf/public_html/" ...@@ -7,11 +7,12 @@ clnet_home := "/project/asdf/public_html/"
sourceDirectory := $(shell pwd) sourceDirectory := $(shell pwd)
lisps = allegro allegromodern ccl clisp sbcl lisps ?= allegro ccl clisp ecl sbcl
## not tested by me: abcl allegromodern cmucl lisworks
## FAIL: gclcvs
## maybe supported by asdf, not supported yet by our tests: cormancl mcl scl
ifndef lisp lisp ?= sbcl
lisp := sbcl
endif
# website, tag, install # website, tag, install
...@@ -26,11 +27,12 @@ archive: FORCE ...@@ -26,11 +27,12 @@ archive: FORCE
bin/build-tarball.sh bin/build-tarball.sh
archive-copy: archive archive-copy: archive
git checkout release
bin/rsync-cp.sh tmp/asdf*.tar.gz $(webhome_private)/archives bin/rsync-cp.sh tmp/asdf*.tar.gz $(webhome_private)/archives
bin/link-tarball.sh $(clnet_home) $(user) bin/link-tarball.sh $(clnet_home) $(user)
bin/rsync-cp.sh tmp/asdf.lisp $(webhome_private) bin/rsync-cp.sh tmp/asdf.lisp $(webhome_private)
git push cl.net git push cl.net release
git push --tags cl.net git push --tags cl.net release
website: website:
make -C doc website make -C doc website
...@@ -54,13 +56,11 @@ clean: FORCE ...@@ -54,13 +56,11 @@ clean: FORCE
make -C doc clean make -C doc clean
test: FORCE test: FORCE
@cd test; make clean;./run-tests.sh $(lisp) $(test-regex) @cd test; make clean;./run-tests.sh ${lisp} ${test-glob}
test-all: FORCE test-all: FORCE
@for lisp in $(lisps); do \ @for lisp in ${lisps} ; do \
make test lisp=$$lisp; \ make test lisp=$$lisp || exit 1 ; \
done done
sbcl --userinit /dev/null --sysinit /dev/null --load bin/make-helper.lisp \
--eval "(write-test-web-pages)" --eval "(quit)"
FORCE: FORCE:
ASDF: another system definition facility ASDF: another system definition facility
======================================== ========================================
If you want to use ASDF to load systems, see the getting If you want to use ASDF, read our manual:
started guide at:
http://common-lisp.net/project/asdf/getting-started.html http://common-lisp.net/project/asdf/asdf.html
If you want to define your own systems, see the manual at: The first few sections, Loading ASDF, Configuring ASDF and Using ASDF,
will get you started as a simple user.
http://common-lisp.net/project/asdf/manual.html If you want to define your own systems, further read the section
Defining systems with defsystem.
More information and additional links can be found on ASDF's More information and additional links can be found on ASDF's
home page at: home page at:
http://common-lisp.net/project/asdf http://common-lisp.net/project/asdf/
last updated Wednesday; May 5, 2010
last updated Saturday; July 18, 2009, 10:20 AM EDT
...@@ -5,14 +5,14 @@ ...@@ -5,14 +5,14 @@
;;; License as published by the Free Software Foundation; either ;;; License as published by the Free Software Foundation; either
;;; version 2 of the License, or (at your option) any later version. ;;; version 2 of the License, or (at your option) any later version.
;;; ;;;
;;; See file '../../Copyright' for full details. ;;; See file 'ecl/Copyright' for full details.
;;; ;;;
;;; ECL SPECIFIC OPERATIONS FOR ASDF ;;; ECL SPECIFIC OPERATIONS FOR ASDF
;;; ;;;
#+xcvb (module (:depends-on ("asdf"))) #+xcvb (module (:depends-on ("asdf")))
(in-package :asdf) (in-package :asdf)
(require 'cmp) (require :cmp)
;;; ;;;
;;; COMPILE-OP / LOAD-OP ;;; COMPILE-OP / LOAD-OP
...@@ -52,12 +52,12 @@ ...@@ -52,12 +52,12 @@
(prologue-code :accessor monolithic-op-prologue-code) (prologue-code :accessor monolithic-op-prologue-code)
(epilogue-code :accessor monolithic-op-epilogue-code))) (epilogue-code :accessor monolithic-op-epilogue-code)))
(defclass monolithic-fasl-op (fasl-op monolithic-bundle-op) ()) (defclass monolithic-fasl-op (monolithic-bundle-op fasl-op) ())
(defclass monolithic-lib-op (lib-op monolithic-bundle-op) (defclass monolithic-lib-op (monolithic-bundle-op lib-op)
((type :initform :lib))) ((type :initform :lib)))
(defclass monolithic-dll-op (dll-op monolithic-bundle-op) (defclass monolithic-dll-op (monolithic-bundle-op dll-op)
((type :initform :dll))) ((type :initform :dll)))
(defclass program-op (monolithic-bundle-op) (defclass program-op (monolithic-bundle-op)
...@@ -66,6 +66,7 @@ ...@@ -66,6 +66,7 @@
(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)
(declare (ignorable initargs name-suffix))
(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" "")))
...@@ -84,6 +85,7 @@ ...@@ -84,6 +85,7 @@
(defvar *force-load-p* nil) (defvar *force-load-p* nil)
(defmethod operation-done-p :around ((operation load-op) c) (defmethod operation-done-p :around ((operation load-op) c)
(declare (ignorable operation c))
(if *force-load-p* nil (call-next-method))) (if *force-load-p* nil (call-next-method)))
(defun gather-components (op-type system &key filter-system filter-type include-self) (defun gather-components (op-type system &key filter-system filter-type include-self)
...@@ -122,6 +124,7 @@ ...@@ -122,6 +124,7 @@
;;; Gather the static libraries of all components. ;;; Gather the static libraries of all components.
;;; ;;;
(defmethod bundle-sub-operations ((o monolithic-bundle-op) c) (defmethod bundle-sub-operations ((o monolithic-bundle-op) c)
(declare (ignorable o))
(gather-components 'lib-op c :filter-type 'system :include-self t)) (gather-components 'lib-op c :filter-type 'system :include-self t))
;;; ;;;
;;; STATIC LIBRARIES ;;; STATIC LIBRARIES
...@@ -141,6 +144,7 @@ ...@@ -141,6 +144,7 @@
;;; with the static library of this module. ;;; with the static library of this module.
;;; ;;;
(defmethod bundle-sub-operations ((o dll-op) c) (defmethod bundle-sub-operations ((o dll-op) c)
(declare (ignorable o))
(list (cons (make-instance 'lib-op) c))) (list (cons (make-instance 'lib-op) c)))
;;; ;;;
;;; FASL FILES ;;; FASL FILES
...@@ -148,6 +152,7 @@ ...@@ -148,6 +152,7 @@
;;; Gather the statically linked library of this component. ;;; Gather the statically linked library of this component.
;;; ;;;
(defmethod bundle-sub-operations ((o fasl-op) c) (defmethod bundle-sub-operations ((o fasl-op) c)
(declare (ignorable o))
(list (cons (make-instance 'lib-op) c))) (list (cons (make-instance 'lib-op) c)))
(defmethod component-depends-on ((o bundle-op) (c system)) (defmethod component-depends-on ((o bundle-op) (c system))
...@@ -157,9 +162,11 @@ ...@@ -157,9 +162,11 @@
(component-name dep)))) (component-name dep))))
(defmethod component-depends-on ((o lib-op) (c system)) (defmethod component-depends-on ((o lib-op) (c system))
(declare (ignorable o))
(list (list 'compile-op (component-name c)))) (list (list 'compile-op (component-name c))))
(defmethod component-depends-on ((o bundle-op) c) (defmethod component-depends-on ((o bundle-op) c)
(declare (ignorable o c))
nil) nil)
(defmethod input-files ((o bundle-op) (c system)) (defmethod input-files ((o bundle-op) (c system))
...@@ -173,17 +180,21 @@ ...@@ -173,17 +180,21 @@
(component-relative-pathname c))))) (component-relative-pathname c)))))
(defmethod output-files ((o fasl-op) (c system)) (defmethod output-files ((o fasl-op) (c system))
(declare (ignorable o c))
(loop for file in (call-next-method) (loop for file in (call-next-method)
collect (make-pathname :type "fasb" :defaults file))) collect (make-pathname :type "fasb" :defaults file)))
(defmethod perform ((o bundle-op) (c t)) (defmethod perform ((o bundle-op) (c t))
(declare (ignorable o c))
t) t)
(defmethod operation-done-p ((o bundle-op) (c source-file)) (defmethod operation-done-p ((o bundle-op) (c source-file))
(declare (ignorable o c))
t) t)
(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
...@@ -197,6 +208,8 @@ ...@@ -197,6 +208,8 @@
(defun select-operation (monolithic type) (defun select-operation (monolithic type)
(ecase type (ecase type
((:binary)
(if monolithic 'monolithic-binary-op 'binary-op))
((:dll :shared-library) ((:dll :shared-library)
(if monolithic 'monolithic-dll-op 'dll-op)) (if monolithic 'monolithic-dll-op 'dll-op))
((:lib :static-library) ((:lib :static-library)
...@@ -206,37 +219,31 @@ ...@@ -206,37 +219,31 @@
((:program) ((:program)
'program-op))) 'program-op)))
(defun make-build (system &rest args &key (monolithic nil) (type :fasl) (defun make-build (system &rest args &key (monolithic nil) (type :fasl)
(move-here nil move-here-p) (move-here nil move-here-p)
&allow-other-keys) &allow-other-keys)
(let* ((operation-name (select-operation monolithic type)) (let* ((operation-name (select-operation monolithic type))
(move-here-path (if (and move-here
(typep move-here '(or pathname string)))
(pathname move-here)
(merge-pathnames "./asdf-output/")))
(operation (apply #'operate operation-name (operation (apply #'operate operation-name
system system
(remove-keys '(monolithic type move-here) args))) (remove-keys '(monolithic type move-here) args)))
(system (find-system system)) (system (find-system system))
(files (and system (output-files operation system)))) (files (and system (output-files operation system))))
(print files) (if (or move-here (and (null move-here-p)
(print move-here) (member operation-name '(:program :binary))))
(if (or move-here (loop with dest-path = (truename (ensure-directories-exist move-here-path))
(and (null move-here-p) for f in files
(member operation-name '(:program)))) for new-f = (make-pathname :name (pathname-name f)
(loop for path in files :type (pathname-type f)
for filename = (namestring (truename path)) :defaults dest-path)
for new-path = (make-pathname :name (pathname-name path) do (progn
:type (pathname-type path) (when (probe-file new-f)
:defaults *default-pathname-defaults*) (delete-file new-f))
for new-filename = (namestring new-path) (rename-file f new-f))
for command = collect new-f)
#+windows
(format nil "move ~S ~S" filename new-filename)
#-windows
(format nil "mv ~S ~S" filename new-filename)
do (unless (equalp new-filename filename)
(when (plusp (si::system (print command)))
(error "Unable to move file~& ~S~&to new location~& ~S"
path new-path)))
collect new-path)
files))) files)))
;;; ;;;
...@@ -251,16 +258,19 @@ ...@@ -251,16 +258,19 @@
(every #'(lambda (c) (typep c 'compiled-file)) (module-components c))) (every #'(lambda (c) (typep c 'compiled-file)) (module-components c)))
(defmethod component-depends-on ((o load-fasl-op) (c system)) (defmethod component-depends-on ((o load-fasl-op) (c system))
(declare (ignorable o))
(unless (trivial-system-p c) (unless (trivial-system-p c)
(subst 'load-fasl-op 'load-op (subst 'load-fasl-op 'load-op
(subst 'fasl-op 'compile-op (subst 'fasl-op 'compile-op
(component-depends-on (make-instance 'load-op) c))))) (component-depends-on (make-instance 'load-op) c)))))
(defmethod input-files ((o load-fasl-op) (c system)) (defmethod input-files ((o load-fasl-op) (c system))
(declare (ignore o))
(unless (trivial-system-p c) (unless (trivial-system-p c)
(output-files (make-instance 'fasl-op) c))) (output-files (make-instance 'fasl-op) c)))
(defmethod perform ((o load-fasl-op) (c t)) (defmethod perform ((o load-fasl-op) (c t))
(declare (ignore o c))
nil) nil)
(defmethod perform ((o load-fasl-op) (c system)) (defmethod perform ((o load-fasl-op) (c system))
...@@ -287,14 +297,19 @@ ...@@ -287,14 +297,19 @@
:type "fas"))) :type "fas")))
(defmethod output-files (o (c compiled-file)) (defmethod output-files (o (c compiled-file))
(declare (ignore o c))
nil) nil)
(defmethod input-files (o (c compiled-file)) (defmethod input-files (o (c compiled-file))
(declare (ignore o c))
nil) nil)
(defmethod perform ((o load-op) (c compiled-file)) (defmethod perform ((o load-op) (c compiled-file))
(declare (ignore o))
(load (component-pathname c))) (load (component-pathname c)))
(defmethod perform ((o load-fasl-op) (c compiled-file)) (defmethod perform ((o load-fasl-op) (c compiled-file))
(declare (ignore o))
(load (component-pathname c))) (load (component-pathname c)))
(defmethod perform (o (c compiled-file)) (defmethod perform (o (c compiled-file))
(declare (ignore o c))
nil) nil)
;;; ;;;
...@@ -304,6 +319,7 @@ ...@@ -304,6 +319,7 @@
((static-library :accessor prebuilt-system-static-library :initarg :lib))) ((static-library :accessor prebuilt-system-static-library :initarg :lib)))
(defmethod output-files ((o lib-op) (c prebuilt-system)) (defmethod output-files ((o lib-op) (c prebuilt-system))
(declare (ignore o))
(values (list (compile-file-pathname (prebuilt-system-static-library c) (values (list (compile-file-pathname (prebuilt-system-static-library c)
:type :lib)) :type :lib))
t ; Advertise that we do not want this path renamed t ; Advertise that we do not want this path renamed
...@@ -313,22 +329,89 @@ ...@@ -313,22 +329,89 @@
(car (output-files o c))) (car (output-files o c)))
(defmethod component-depends-on ((o lib-op) (c prebuilt-system)) (defmethod component-depends-on ((o lib-op) (c prebuilt-system))
(declare (ignorable o c))
nil) nil)
(defmethod bundle-sub-operations ((o lib-op) (c prebuilt-system)) (defmethod bundle-sub-operations ((o lib-op) (c prebuilt-system))
(declare (ignorable o c))
nil) nil)
(defmethod bundle-sub-operations ((o monolithic-lib-op) (c prebuilt-system)) (defmethod bundle-sub-operations ((o monolithic-lib-op) (c prebuilt-system))
(declare (ignorable o))
(error "Prebuilt system ~S shipped with ECL can not be used in a monolithic library operation." c)) (error "Prebuilt system ~S shipped with ECL can not be used in a monolithic library operation." c))
(defmethod bundle-sub-operations ((o monolithic-bundle-op) (c prebuilt-system)) (defmethod bundle-sub-operations ((o monolithic-bundle-op) (c prebuilt-system))
(declare (ignorable o c))
nil) nil)
;;;
;;; PREBUILT SYSTEM CREATOR
;;;
(defclass binary-op (bundle-op)
())
(defclass monolithic-binary-op (binary-op monolithic-bundle-op)
())
(defun binary-op-dependencies (o s)
(let (lib-op fasl-op)
(if (bundle-op-monolithic-p o)
(setf lib-op 'monolithic-lib-op
fasl-op 'monolithic-fasl-op)
(setf lib-op 'lib-op
fasl-op 'fasl-op))
(list (list (make-instance lib-op :args (bundle-op-build-args o))
s)
(list (make-instance fasl-op :args (bundle-op-build-args o))
s))))
(defmethod component-depends-on ((o binary-op) (s system))
(loop for dep in (binary-op-dependencies o s)
append (apply #'component-depends-on dep)))
(defmethod input-files ((o binary-op) (s system))
(loop for dep in (binary-op-dependencies o s)
append (apply #'input-files dep)))
(defmethod output-files ((o binary-op) (s system))
(list* (merge-pathnames* (make-pathname :name (component-name s)
:type "asd")
(component-relative-pathname s))
(loop for dep in (binary-op-dependencies o s)
append (apply #'output-files dep))))
(defmethod perform ((o binary-op) (s system))
(let* ((dependencies (binary-op-dependencies o s))
(library (first (apply #'output-files (first dependencies))))
(fasl (first (apply #'output-files (second dependencies))))
(filename (first (output-files o s)))
(name (component-name s))
(name-keyword (intern (string name) (find-package :keyword))))
(loop for dep in dependencies
do (apply #'perform dep))
(with-open-file (s filename :direction :output :if-exists :supersede
:if-does-not-exist :create)
(format s ";;; Prebuilt ASDF definition for system ~A" name)
(format s ";;; Built for ~A ~A on a ~A/~A ~A"
(lisp-implementation-type)
(lisp-implementation-version)
(software-type)
(machine-type)
(software-version))
(let ((*package* (find-package :keyword)))
(pprint `(defsystem ,name-keyword
:class asdf::prebuilt-system
:components ((:compiled-file ,(pathname-name fasl)))
:lib ,(make-pathname :name (pathname-name library)
:type (pathname-type library)))
s)))))
;;; ;;;
;;; Final integration steps ;;; Final integration steps
;;; ;;;
(export '(make-build load-fasl-op)) (export '(make-build load-fasl-op prebuilt-system))
(push '("fasb" . si::load-binary) si::*load-hooks*) (push '("fasb" . si::load-binary) si::*load-hooks*)
(require 'cmp) (require 'cmp)
......
#|| sh asdf-install.lisp will compile this file to an exe called asdf-install
sbcl <<EOF
(require 'sb-executable)
(compile-file "asdf-install.lisp")
(sb-executable:make-executable "asdf-install" *)
EOF
exit 0
||#
;;; Install an ASDF system or anything else that looks convincingly
;;; like one, including updating symlink for all the toplevel .asd files it
;;; contains
;;; If the file $HOME/.asdf-install exists, it is loaded. This can be
;;; used to override the default values of exported special variables
;;; (see the defpackage form for details) - however, most of them are
;;; sensible and/or taken from the environment anyway
#||
TODO:
a) gpg signature checking would be better if it actually checked against
a list of "trusted to write Lisp" keys, instead of just "trusted to be
who they say they are"
d) in sbcl 0.8.1 we'll have a run-program that knows about $PATH and so
won't need to hardcode gpgpgpgp and tar locations.
e) nice to have: resume half-done downloads instead of starting from scratch
every time. but right now we're dealing in fairly small packages, this is not
an immediate concern
||#
(in-package :cl-user)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require 'asdf)
(require 'sb-posix)
(require 'sb-executable)
(require 'sb-bsd-sockets))
(defpackage :asdf-install
(:use "CL" "SB-EXT" "SB-BSD-SOCKETS")
(:export #:*proxy* #:*cclan-mirror* #:*sbcl-home*
#:*verify-gpg-signatures* #:*locations*))
(defpackage :asdf-install-customize
(:use "CL" "SB-EXT" "SB-BSD-SOCKETS" "ASDF-INSTALL"))
(in-package :asdf-install)
(defvar *proxy* (posix-getenv "http_proxy"))
(defvar *cclan-mirror*
(or (posix-getenv "CCLAN_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
;; want a directory
(let ((path (pathname name)))
(if (pathname-name path)
(merge-pathnames
(make-pathname :directory `(:relative ,(pathname-name path))
:name "")
path)
path)))
(defvar *sbcl-home* (directorify (posix-getenv "SBCL_HOME")))
(defvar *dot-sbcl*
(merge-pathnames (make-pathname :directory '(:relative ".sbcl"))
(user-homedir-pathname)))
(defvar *verify-gpg-signatures* t)
(defvar *locations*
`((,(merge-pathnames "site/" *sbcl-home*)
,(merge-pathnames "site-systems/" *sbcl-home*)
"System-wide install")
(,(merge-pathnames "site/" *dot-sbcl*)
,(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)))
(define-condition download-error (error)
((url :initarg :url :reader download-url)
(response :initarg :response :reader download-response))
(:report (lambda (c s)
(format s "Server responded ~A for GET ~A"
(download-response c) (download-url c)))))
(define-condition signature-error (error)
((cause :initarg :cause :reader signature-error-cause))
(:report (lambda (c s)
(format s "Cannot verify package signature: ~A"
(signature-error-cause c)))))
(defun url-host (url)
(assert (string-equal url "http://" :end1 7))
(let* ((port-start (position #\: url :start 7))
(host-end (min (or (position #\/ url :start 7) (length url))
(or port-start (length url)))))
(subseq url 7 host-end)))
(defun url-port (url)
(assert (string-equal url "http://" :end1 7))
(let ((port-start (position #\: url :start 7)))
(if port-start (parse-integer url :start port-start :junk-allowed t) 80)))
(defun url-connection (url)
(let ((s (make-instance 'inet-socket :type :stream :protocol :tcp))
(host (url-host url))
(port (url-port url)))
(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)))
;; 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))))
(defun download (package-name-or-url file-name)
(let ((url
(if (= (mismatch package-name-or-url "http://") 7)
package-name-or-url
(format nil "http://www.cliki.net/~A?download"
package-name-or-url))))
(destructuring-bind (response headers stream)
(block got
(loop
(destructuring-bind (response headers stream) (url-connection url)
(unless (member response '(301 302))
(return-from got (list response headers stream)))
(close stream)
(setf url (cdr (assoc :location headers))))))
(if (>= response 400)
(error 'download-error :url url :response response))
(let ((length (parse-integer
(or (cdr (assoc :content-length headers)) "")
:junk-allowed t)))
(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)
(if length
(let ((buf (make-array length
:element-type
(stream-element-type stream) )))
(read-sequence buf stream)
(write-sequence buf o))
(sb-executable:copy-stream stream o))))
(close stream)
(terpri)
;; seems to have worked. let's try for a detached gpg signature too
(when *verify-gpg-signatures*
(verify-gpg-signature url file-name)))))
(defun verify-gpg-signature (url file-name)
(destructuring-bind (response headers stream)
(url-connection (concatenate 'string url ".asc"))
(declare (ignore headers))
(unwind-protect
(if (= response 200)
;; sadly, we can't pass the stream directly to run-program,
;; because (at least in sbcl 0.8) that ignores existing buffered
;; data and only reads new fresh data direct from the file
;; descriptor
(let ((data (make-string (parse-integer
(cdr (assoc :content-length headers))
:junk-allowed t))))
(read-sequence data stream)
(let ((ret
(process-exit-code
(sb-ext:run-program "/usr/bin/gpg"
(list "--verify" "-"
(namestring file-name))
:output t
:input (make-string-input-stream data)
:wait t))))
(unless (zerop ret)
(error 'signature-error
:cause (make-condition
'simple-error
:format-control "GPG returned exit status ~A"
:format-arguments (list ret))))))
(error 'signature-error
:cause
(make-condition
'download-error :url (concatenate 'string url ".asc")
:response response)))
(close stream))))
(defun where ()
(format t "Install where?~%")
(loop for (source system name) in *locations*
for i from 1
do (format t "~A) ~A: ~% System in ~A~% Files in ~A ~%"
i name system source))
(format t " --> ") (force-output)
(let ((response (read)))
(when (> response 0)
(elt *locations* (1- response)))))
(defun install (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 "/bin/tar"
(list "-C" (namestring source)
"-xzvf" (namestring packagename))
:output o
:wait t)
(error "can't untar"))))
(dummy (princ tar))
(pos-slash (position #\/ tar))
(*default-pathname-defaults*
(merge-pathnames
(make-pathname :directory
`(:relative ,(subseq tar 0 pos-slash)))
source)))
(loop for asd in (directory
(make-pathname :name :wild :type "asd"))
do (let ((target (merge-pathnames
(make-pathname :name (pathname-name asd)
:type (pathname-type asd))
system)))
(when (probe-file target)
(sb-posix:unlink target))
(sb-posix:symlink asd target))
collect (pathname-name asd))))
(defvar *temporary-files*)
(defun temp-file-name (p)
(let* ((pos-slash (position #\/ p :from-end t))
(pos-dot (position #\. p :start (or pos-slash 0))))
(merge-pathnames
(make-pathname
:name (subseq p (if pos-slash (1+ pos-slash) 0) pos-dot)
:type "asdf-install-tmp"))))
(defun run (&optional (packages (cdr *posix-argv*)))
(destructuring-bind (source system name) (where)
(labels ((one-iter (packages)
(dolist (asd
(loop for p in packages
unless (probe-file p)
do (let ((tmp (temp-file-name p)))
(pushnew tmp *temporary-files*)
(download p tmp)
(setf p tmp))
end
do (format t "Installing ~A in ~A,~A~%" p source system)
append (install source system p)))
(handler-case
(asdf:operate 'asdf:load-op asd)
(asdf:missing-dependency (c)
(format t "Downloading package ~A, required by ~A~%"
(asdf::missing-requires c)
(asdf:component-name (asdf::missing-required-by c)))
(one-iter (list
(symbol-name (asdf::missing-requires c)))))))))
(one-iter packages))))
(handler-case
(let ((*temporary-files* nil))
(unwind-protect
(run)
(dolist (l *temporary-files*)
(when (probe-file l) (delete-file l)))))
(error (c)
(princ "Install failed due to error:") (terpri)
(princ c) (terpri)
(quit :unix-status 1)))
;(quit)
\ No newline at end of file
...@@ -3,7 +3,7 @@ ...@@ -3,7 +3,7 @@
;;; ;;; ;;; ;;;
;;; Free Software available under an MIT-style license. ;;; ;;; Free Software available under an MIT-style license. ;;;
;;; ;;; ;;; ;;;
;;; Copyright (c) 2001-2009 Daniel Barlow and contributors ;;; ;;; Copyright (c) 2001-2010 Daniel Barlow and contributors ;;;
;;; ;;; ;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
......
This diff is collapsed.
(in-package :cl-user)
(defpackage :cclan (:use #:cl #:asdf)
(:export #:all-components #:write-package))
;;; -*- Lisp -*-
(defpackage :cclan-system (:use #:cl #:asdf))
(in-package :cclan-system)
(defsystem cclan
:version "0.1"
:components ((:file "cclan-package")
(:file "cclan" :depends-on ("cclan-package"))))
(in-package :cclan)
;;;; This file contains functions, classes etc that are not part of
;;;; asdf itself, but extend it in various ways useful for maintainers
;;;; of new-style cCLan packages
;;;; The public interface consists of the functions whose symbols are
;;;; exported from the package
;;;; This file does not contain references to asdf internals - or
;;;; shouldn't, anyway. Send bug reports
(defun mapappend (function list)
(let ((f (coerce function 'function)))
(loop for i in list append (funcall f i))))
(defgeneric all-components (component))
(defmethod all-components ((source-file source-file))
(list source-file))
(defmethod all-components ((module module))
(cons module (mapappend #'all-components (module-components module))))
(defmethod all-components ((module symbol))
(all-components (find-system module)))
(defun cvs-tag-name (system)
(let* ((system (find-system system))
(version (component-version system)))
(format nil "release_~A" (substitute #\_ #\. version))))
(defun cvs-tag (system)
(let* ((system (find-system system))
(directory (component-pathname system)))
(run-shell-command "cd ~A && cvs tag -F ~A"
(namestring directory) (cvs-tag-name system))))
(defun write-readme-file (stream suggested-registry system-name)
"Write a README.install file detailing a possible sequence of commands to use the newly-untarred system."
(format stream "~
1. Make a symlink in ~W[*] pointing to the .asd file
2. Start your asdf-enabled lisp
2a. Ensure that ~W[*] is in asdf:*central-registry*
3. At the lisp prompt, type '(asdf:operate 'asdf:load-op ~W)'. This
will compile and load the system into your running lisp.
[*] This path (~W) is only a suggestion; the important
thing is that asdf know where to find the .asd file. asdf uses the
contents of the variable ASDF:*CENTRAL-REGISTRY* to find its system
definitions.
These instructions were automatically generated by cCLan software. Use
at your own peril.~%" suggested-registry suggested-registry system-name suggested-registry))
(defun write-package (system)
(let* ((parent-dir
(parse-namestring
(format nil "/tmp/~A.~A/"
#+sbcl (sb-unix:unix-getpid)
#-sbcl (random 1000000)
(get-internal-run-time))))
(system (find-system system))
(sub-dir-name
(format nil "~A_~A"
(component-name system) (component-version system)))
(cvsroot-file
(merge-pathnames "CVS/Root" (component-pathname system)))
(old-pwd *default-pathname-defaults*)
(*default-pathname-defaults* parent-dir))
(ensure-directories-exist parent-dir)
(cvs-tag system)
(and
(zerop (asdf:run-shell-command
"cd ~A && cvs -d `cat ~A` checkout -d ~A -r ~A -kv ~A"
(namestring parent-dir)
(namestring cvsroot-file)
sub-dir-name
(cvs-tag-name system)
(component-name system)))
(with-open-file (o (format nil "~A/INSTALL.asdf" sub-dir-name)
:direction :output)
(write-readme-file o "$HOME/lisp/systems/" (component-name system))
t)
(zerop (asdf:run-shell-command "cd ~A && tar cf ~A~A.tar ~A"
(namestring parent-dir)
(namestring old-pwd) sub-dir-name
sub-dir-name))
(zerop (asdf:run-shell-command
"gzip -f9 ~A~A.tar"
(namestring old-pwd) sub-dir-name))
(format t "Now run~% gpg -b -a ~A~A.tar.gz~%in a shell with a tty"
(namestring old-pwd) sub-dir-name))))
(defun class-name-of (x)
(class-name (class-of x)))
This diff is collapsed.
...@@ -26,12 +26,18 @@ ...@@ -26,12 +26,18 @@
</ul> </ul>
</div> </div>
<div class="contents"> <div class="contents">
<a id="ASDF 2"></a>
<h3>ASDF 2</h3>
<p>We recently released ASDF 2 (on May 31st 2010).
It will hopefully be bundled will all official releases
of Common Lisp implementations made after that date.
</p>
<a id="what_it_is"></a> <a id="what_it_is"></a>
<h3>What it is</h3> <h3>What it is</h3>
<p>ASDF is a tool for describing how source files are organized: <p>ASDF is a tool for describing how source files are organized:
what depends on which and when. what depends on which and when.
</p> </p>
<p>It is roughly what Common-Lisp hackers use to build software <p>It is roughly what Common Lisp hackers use to build software
where C hackers would use say GNU Make. where C hackers would use say GNU Make.
</p> </p>
<p>ASDF stands for <em>A</em>nother <em>S</em>ystem <em>D</em>efinition <em>F</em>acility, <p>ASDF stands for <em>A</em>nother <em>S</em>ystem <em>D</em>efinition <em>F</em>acility,
...@@ -47,7 +53,7 @@ ...@@ -47,7 +53,7 @@
<li><a href="http://common-lisp.net/gitweb?p=projects/asdf/asdf.git;a=blob;f=asdf.texinfo">as texinfo source</a></li> <li><a href="http://common-lisp.net/gitweb?p=projects/asdf/asdf.git;a=blob;f=asdf.texinfo">as texinfo source</a></li>
</ul> </ul>
<a href="downloads"></a> <a id="downloads"></a>
<h3>Getting it</h3> <h3>Getting it</h3>
<p>Though they may lag behind the version here, ASDF comes bundled with most Lisps. <p>Though they may lag behind the version here, ASDF comes bundled with most Lisps.
To get the greatest and latest, you can: To get the greatest and latest, you can:
...@@ -64,7 +70,9 @@ ...@@ -64,7 +70,9 @@
</li> </li>
<li>pull the latest from our git repository <li>pull the latest from our git repository
(<a href="http://common-lisp.net/gitweb?p=projects/asdf/asdf.git">browse</a>) (<a href="http://common-lisp.net/gitweb?p=projects/asdf/asdf.git">browse</a>)
<pre>git clone http://common-lisp.net/project/asdf/asdf.git</pre> <pre>git clone git://common-lisp.net/projects/asdf/asdf.git</pre>
(Note that our "master" branch is for current development;
get our "release" branch for the latest stable release.)
</li></ul> </li></ul>
<a id="bugs"> <a id="bugs">
...@@ -90,19 +98,20 @@ ...@@ -90,19 +98,20 @@
<a id="news"></a> <a id="news"></a>
<h3>What is happening</h3> <h3>What is happening</h3>
<dl> <dl>
<dt>December 2009 to April 2010</dt> <dt>December 2009 to June 2010</dt>
<dd>Fran&ccedil;ois-Ren&eacute; Rideau is de facto maintainer, <dd>Fran&ccedil;ois-Ren&eacute; Rideau is de facto maintainer,
with notable contributions from Robert P. Goldman. with notable contributions from Robert P. Goldman,
Push towards an ASDF 2 release Juanjo Garcia-Ripoll and James Anderson.
ASDF 2 released
with many clean-ups, better configurability with many clean-ups, better configurability
and updated documentation. and updated documentation.
</dd> </dd>
<dt>May 2006 to November 2009</dt> <dt>May 2006 to November 2009</dt>
<dd>Gary King is de facto maintainer, <dd>Gary King is de facto maintainer,
with notable contributions from with notable contributions from
Robert P. Goldman, Nikodemus Siivola, Christophe Rhodes, D Herring. Robert P. Goldman, Nikodemus Siivola, Christophe Rhodes, Daniel Herring.
Many small features and bug fixes, Many small features and bug fixes,
trying to make the project more usable, making the project more maintanable,
moving to using git and common-lisp.net. moving to using git and common-lisp.net.
</dd> </dd>
<dt>May 2004 to April 2006</dt> <dt>May 2004 to April 2006</dt>
...@@ -124,7 +133,7 @@ ...@@ -124,7 +133,7 @@
<a class="nav" href="http://common-lisp.net/" title="Common-Lisp.net"> <img src="http://common-lisp.net/project/cl-containers/shared/buttons/lisp-lizard.png" width="80" height="15" title="Common-Lisp.net" alt="Common-Lisp.net button" /></a> <a class="nav" href="http://common-lisp.net/" title="Common-Lisp.net"> <img src="http://common-lisp.net/project/cl-containers/shared/buttons/lisp-lizard.png" width="80" height="15" title="Common-Lisp.net" alt="Common-Lisp.net button" /></a>
<p><span class="copyright"Copyright &copy; 2001-2010 Daniel Barlow and contributors</span></p> <p><span class="copyright"Copyright &copy; 2001-2010 Daniel Barlow and contributors</span></p>
<p>ASDF has an <a href="http://www.opensource.org/licenses/mit-license.php">MIT style</a> license</p> <p>ASDF has an <a href="http://www.opensource.org/licenses/mit-license.php">MIT style</a> license</p>
<div id="timestamp">Last updated 2010-04-08</div> <div id="timestamp">Last updated 2010-06-02</div>
</div> </div>
</body> </body>
</html> </html>
...@@ -185,11 +185,11 @@ ...@@ -185,11 +185,11 @@
(handler-bind (handler-bind
((error (lambda (c) ((error (lambda (c)
(incf system-failures) (incf system-failures)
(format *error-output* "~&error! ~a~%sysdef:~% ~W~%" c system-definition) (format *error-output* "~&error! ~a~%sysdef:~% ~S~%" c system-definition)
#+sbcl (sb-debug:backtrace 69) #+sbcl (sb-debug:backtrace 69)
#+clozure (ccl:print-call-history :count 69 :start-frame-number 1) #+clozure (ccl:print-call-history :count 69 :start-frame-number 1)
#+clisp (system::print-backtrace) #+clisp (system::print-backtrace)
(format result-stream "~&~%***~%error: ~a~%~:w" (format result-stream "~&~%***~%error: ~a~%~s"
c system-definition) c system-definition)
(return-from :test-system)))) (return-from :test-system))))
(unless (and (or (typep system-pathname 'logical-pathname) (unless (and (or (typep system-pathname 'logical-pathname)
...@@ -241,9 +241,9 @@ ...@@ -241,9 +241,9 @@
:missing))) :missing)))
test-files)) test-files))
(format result-stream "~&~%~% translations: ~a: ~:w" "ASDFTEST" (logical-pathname-translations "ASDFTEST")) (format result-stream "~&~%~% translations: ~a: ~s" "ASDFTEST" (logical-pathname-translations "ASDFTEST"))
(format result-stream "~&~%~% variations:~% systems: ~:w~% modules: ~:w~% files: ~:w" (format result-stream "~&~%~% variations:~% systems: ~s~% modules: ~s~% files: ~s"
systems modules files) systems modules files)
(let ((homogeneous-failures 0) (*print-length* nil)) (let ((homogeneous-failures 0) (*print-length* nil))
......
...@@ -18,18 +18,14 @@ ...@@ -18,18 +18,14 @@
#'(lambda (w) #'(lambda (w)
(princ w *error-output*) (princ w *error-output*)
(muffle-warning w)))) (muffle-warning w))))
(compile-file *asdf-lisp* :output-file tmp)) (compile-file *asdf-lisp* :output-file tmp :print t :verbose t))
(declare (ignore result)) (declare (ignore result))
(cond (cond
#-ecl
(warnings-p (warnings-p
(leave-lisp "Testsuite failed: ASDF compiled with warnings" 1)) (leave-lisp "Testsuite failed: ASDF compiled with warnings" 1))
(errors-p (errors-p
(leave-lisp "Testsuite failed: ASDF compiled with ERRORS" 2)) (leave-lisp "Testsuite failed: ASDF compiled with ERRORS" 2))
(t (t
#+ecl
(when warnings-p
(format t "~&ASDF compiled with warnings. Please fix ECL.~%"))
(when (probe-file *asdf-fasl*) (when (probe-file *asdf-fasl*)
(delete-file *asdf-fasl*)) (delete-file *asdf-fasl*))
(rename-file tmp *asdf-fasl*) (rename-file tmp *asdf-fasl*)
......
...@@ -86,6 +86,7 @@ do_tests() { ...@@ -86,6 +86,7 @@ do_tests() {
echo " $test_pass passing and $test_fail failing" >&2 echo " $test_pass passing and $test_fail failing" >&2
if [ $test_fail -eq 0 ] ; then if [ $test_fail -eq 0 ] ; then
echo "all tests apparently successful" >&2 echo "all tests apparently successful" >&2
echo success > ../tmp/results/status
else else
echo "failing test(s): $failed_list" >&2 echo "failing test(s): $failed_list" >&2
fi fi
...@@ -190,8 +191,11 @@ if [ -z "$command" ] ; then ...@@ -190,8 +191,11 @@ if [ -z "$command" ] ; then
else else
create_config create_config
mkdir -p ../tmp/results mkdir -p ../tmp/results
echo failure > ../tmp/results/status
thedate=`date "+%Y-%m-%d"` thedate=`date "+%Y-%m-%d"`
do_tests "$command" "$eval" 2>&1 | \ do_tests "$command" "$eval" 2>&1 | \
tee "../tmp/results/${lisp}.text" "../tmp/results/${lisp}-${thedate}.save" tee "../tmp/results/${lisp}.text" "../tmp/results/${lisp}-${thedate}.save"
read a < ../tmp/results/status
clean_up clean_up
[ success = "$a" ] ## exit code
fi fi
...@@ -43,6 +43,7 @@ ...@@ -43,6 +43,7 @@
;;; code adapted from cl-launch (any errors in transcription are mine!) ;;; code adapted from cl-launch (any errors in transcription are mine!)
;; http://www.cliki.net/cl-launch ;; http://www.cliki.net/cl-launch
(defun leave-lisp (message return) (defun leave-lisp (message return)
(fresh-line *error-output*)
(when message (when message
(format *error-output* message) (format *error-output* message)
(terpri *error-output*)) (terpri *error-output*))
......
(defsystem test-compile-file-failure
:components ((:file "test-compile-file-failure")))
(eval-when (:compile-toplevel :load-toplevel :execute)
;; CLISP 2.48 has a bug that makes this test fail. Work around:
#+clisp (when (eq asdf:*compile-file-failure-behaviour* :error) (error 'asdf:compile-error))
(warn "Warning."))
;;; -*- Lisp -*-
(load "script-support")
(load-asdf)
(quit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(assert (handler-case
(let ((asdf:*compile-file-failure-behaviour* :warn))
(asdf:load-system 'test-compile-file-failure :force t)
t)
(asdf:compile-error () nil)))
(assert (handler-case
(let ((asdf:*compile-file-failure-behaviour* :error))
(asdf:load-system 'test-compile-file-failure :force t)
nil)
(asdf:compile-error () t))))
...@@ -29,7 +29,7 @@ ...@@ -29,7 +29,7 @@
(call-next-method))) (call-next-method)))
(defmethod find-component :around ((m (eql (find-quux))) (defmethod find-component :around ((m (eql (find-quux)))
(c string) &optional version) (c string))
"FIND-COMPONENT on a component is a no-op --- it's already found." "FIND-COMPONENT on a component is a no-op --- it's already found."
(declare (ignore version)) (declare (ignore version))
(if (string-equal c "file3-only") (if (string-equal c "file3-only")
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment