[armedbear-cvs] r12487 - in trunk/abcl: . contrib contrib/asdf-install
Mark Evenson
mevenson at common-lisp.net
Sat Feb 20 12:04:16 UTC 2010
Author: mevenson
Date: Sat Feb 20 07:04:14 2010
New Revision: 12487
Log:
Port of ASDF-INSTALL under 'contrib/asdf-install'.
'abcl.contrib' will package ASDF-INSTALL in dist/abcl-contrib.jar.
We only have one contrib 'asdf-install'. It is not expected to work
well under Windows at the moment.
To use ASDF-INSTALL, use the following in your ~/.abclrc:
(require 'asdf)
(pushnew "jar:file:${dist.dir}/abcl-contrib.jar!/asdf-install/" asdf:*central-registry*)
Then issuing
CL-USER> (require 'asdf-install)
will load ASDF-INSTALL.
A file ~/.asdf-install can contain customizations to help ASDF-INSTALL
find the programs 'tar' and 'gpg'. 'tar' is searched for in
asdf-install:*shell-search-paths*. The location of 'gpg' can be
customized by setting *gpg-command* to a string containing the file.
This behavior should be rationalized in the future.
ASDF-INSTALL tested under OSX.
Added:
trunk/abcl/contrib/
trunk/abcl/contrib/asdf-install/
trunk/abcl/contrib/asdf-install/COPYRIGHT
trunk/abcl/contrib/asdf-install/Makefile
trunk/abcl/contrib/asdf-install/README
trunk/abcl/contrib/asdf-install/RELNOTES
trunk/abcl/contrib/asdf-install/asdf-install.asd
trunk/abcl/contrib/asdf-install/conditions.lisp
trunk/abcl/contrib/asdf-install/dead-letter.lisp
trunk/abcl/contrib/asdf-install/defpackage.lisp
trunk/abcl/contrib/asdf-install/deprecated.lisp
trunk/abcl/contrib/asdf-install/digitool.lisp
trunk/abcl/contrib/asdf-install/installer.lisp
trunk/abcl/contrib/asdf-install/lift-standard.config
trunk/abcl/contrib/asdf-install/load-asdf-install.lisp
trunk/abcl/contrib/asdf-install/loader.lisp
trunk/abcl/contrib/asdf-install/port.lisp
trunk/abcl/contrib/asdf-install/split-sequence.lisp
trunk/abcl/contrib/asdf-install/variables.lisp
Modified:
trunk/abcl/build.xml
Modified: trunk/abcl/build.xml
==============================================================================
--- trunk/abcl/build.xml (original)
+++ trunk/abcl/build.xml Sat Feb 20 07:04:14 2010
@@ -346,6 +346,41 @@
<property name="abcl.wrapper.in.file" value="abcl.bat.in"/>
</target>
+ <!-- XXX Generalize when (if?) we get more contribs -->
+ <target name="abcl.contrib" depends="abcl.jar">
+ <java fork="true"
+ failonerror="true"
+ classpathref="abcl.classpath.dist"
+ dir="${basedir}/contrib/asdf-install/"
+ inputstring="(require 'asdf) (asdf:operate 'asdf:compile-op :asdf-install)"
+ classname="org.armedbear.lisp.Main">
+ <arg value="--noinit"/>
+ </java>
+ <jar destfile="dist/abcl-contrib.jar"
+ compress="true"
+ basedir="contrib">
+ <patternset>
+ <include name="**/*.asd"/>
+ <include name="**/*.lisp"/>
+ <include name="**/*.abcl"/>
+ </patternset>
+ </jar>
+ <echo>
+Packaged contribs in ${dist.dir}/abcl-contrib.jar.
+
+To use ASDF-INSTALL, use the following in your ~/.abclrc:
+
+ (require 'asdf)
+ (pushnew "jar:file:${dist.dir}/abcl-contrib.jar!/asdf-install/" asdf:*central-registry*)
+
+Then issuing
+
+ CL-USER> (require 'asdf-install)
+
+will load ASDF-INSTALL.
+</echo>
+ </target>
+
<target name="abcl.debug.jpda" depends="abcl.jar">
<description>Invoke ABCL with JPDA listener on port 6789</description>
<java fork="true"
Added: trunk/abcl/contrib/asdf-install/COPYRIGHT
==============================================================================
--- (empty file)
+++ trunk/abcl/contrib/asdf-install/COPYRIGHT Sat Feb 20 07:04:14 2010
@@ -0,0 +1,47 @@
+The original ASDF-INSTALL code (the files Makefile, README,
+asdf-install.asd, defpackage.lisp, and installer.lisp) was written by
+Daniel Barlow <dan at telent.net> and is distributed with SBCL and
+therefore in the public domain. The SBCL Common Lisp implementation
+can be obtained from Sourceforge: <http://sbcl.sf.net/>.
+
+The initial port of ASDF-INSTALL to other Lisps was done by Dr. Edmund
+Weitz <edi at agharta.de> and included the file port.lisp and some
+changes to the files mentioned above. More code was provided by Marco
+Baringer <mb at bese.it> (OpenMCL port), James Anderson
+<james.anderson at setf.de> (MCL port, including the file digitool.lisp),
+Kiyoshi Mizumaru <maru at krc.sony.co.jp>, Robert P. Goldman
+<rpgoldman at sift.info>, and Raymond Toy <toy at rtp.ericsson.se>
+(bugfixes). Marco Antoniotti <marcoxa at cs.nyu.edu> added support for
+MK:DEFSYSTEM which includes the files load-asdf-install.lisp,
+loader.lisp, and finally split-sequence.lisp which has its own
+copyright notice. ASDF-Install is currently maintained by Gary King
+<gwking at metabang.com> and is hosted on Common-Lisp.net.
+
+The complete code distributed with this archive (asdf-install.tar.gz)
+is copyrighted by the above-mentioned authors and governed by the
+following license.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials
+ provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHORS 'AS IS' AND ANY EXPRESSED OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT,
+INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING
+IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
Added: trunk/abcl/contrib/asdf-install/Makefile
==============================================================================
--- (empty file)
+++ trunk/abcl/contrib/asdf-install/Makefile Sat Feb 20 07:04:14 2010
@@ -0,0 +1,13 @@
+SYSTEM=asdf-install
+EXTRA_INSTALL_TARGETS=asdf-install-install
+
+include ../asdf-module.mk
+
+asdf-install-install: asdf-install
+ if test -f $(BUILD_ROOT)$(INSTALL_ROOT)/bin/sbcl-asdf-install ; then \
+ mv $(BUILD_ROOT)$(INSTALL_ROOT)/bin/sbcl-asdf-install $(BUILD_ROOT)$(INSTALL_ROOT)/bin/sbcl-asdf-install.old ; \
+ fi
+# KLUDGE: mv rather than cp because keeping asdf-install in that
+# directory interferes with REQUIRE, and this is done before the tar
+# in ../asdf-module.mk. Better solutions welcome.
+ mv asdf-install $(BUILD_ROOT)$(INSTALL_ROOT)/bin/sbcl-asdf-install
Added: trunk/abcl/contrib/asdf-install/README
==============================================================================
--- (empty file)
+++ trunk/abcl/contrib/asdf-install/README Sat Feb 20 07:04:14 2010
@@ -0,0 +1,121 @@
+Downloads and installs an ASDF or a MK:DEFSYSTEM system or anything
+else that looks convincingly like one. It updates the
+ASDF:*CENTRAL-REGISTRY* symlinks for all the toplevel .asd files it
+contains, and it also MK:ADD-REGISTRY-LOCATION for the appropriate
+directories for MK:DEFSYSTEM.
+
+Please read this file before use: in particular: this is an automatic
+tool that downloads and compiles stuff it finds on the 'net. Please
+look at the SECURITY section and be sure you understand the
+implications
+
+
+= USAGE
+
+This can be used either from within a CL implementation:
+
+cl-prompt> (load "/path/to/load-asdf-install.lisp")
+cl-prompt> (asdf-install:install 'xlunit) ; for example
+
+With SBCL you can also use the standalone command `sbcl-asdf-install'
+from the shell:
+
+$ sbcl-asdf-install xlunit
+
+
+Each argument may be -
+
+ - The name of a cliki page. asdf-install visits that page and finds
+ the download location from the `:(package)' tag - usually rendered
+ as "Download ASDF package from ..."
+
+ - A URL, which is downloaded directly
+
+ - A local tar.gz file, which is installed
+
+
+= SECURITY CONCERNS: READ THIS CAREFULLY
+
+When you invoke asdf-install, you are asking your CL implementation to
+download, compile, and install software from some random site on the
+web. Given that it's indirected through a page on CLiki, any
+malicious third party doesn't even need to hack the distribution
+server to replace the package with something else: he can just edit
+the link.
+
+For this reason, we encourage package providers to crypto-sign their
+packages (see details at the URL in the PACKAGE CREATION section) and
+users to check the signatures. asdf-install has three levels of
+automatic signature checking: "on", "off" and "unknown sites", which
+can be set using the configuration variables described in
+CUSTOMIZATION below. The default is "unknown sites", which will
+expect a GPG signature on all downloads except those from
+presumed-good sites. The current default presumed-good sites are
+CCLAN nodes, and two web sites run by SBCL maintainers: again, see
+below for customization details
+
+
+= CUSTOMIZATION
+
+If the file $HOME/.asdf-install exists, it is loaded. This can be
+used to override the default values of exported special variables.
+Presently these are
+
+*PROXY*
+ defaults to $http_proxy environment variable
+*CCLAN-MIRROR*
+ preferred/nearest CCLAN node. See the list at
+ http://ww.telent.net/cclan-choose-mirror
+*ASDF-INSTALL-DIRS*
+ Set from ASDF_INSTALL_DIR environment variable. If you are running
+ SBCL, then *ASDF-INSTALL-DIRS* may be set form the environment variable
+ SBCL_HOME, which should already be correct for whatever SBCL is
+ running, if it's been installed correctly. This is done for
+ backward compatibility with SBCL installations.
+*SBCL-HOME*
+ This is actually a symbol macro for *ASDF-INSTALL-DIRS*
+*VERIFY-GPG-SIGNATURES*
+ Verify GPG signatures for the downloaded packages?
+ NIL - no, T - yes, :UNKNOWN-LOCATIONS - only for URLs which aren't in CCLAN
+ and don't begin with one of the prefixes in *SAFE-URL-PREFIXES*
+*LOCATIONS*
+ Possible places in the filesystem to install packages into. See default
+ value for format
+*SAFE-URL-PREFIXES*
+ List of locations for which GPG signature checking /won't/ be done when
+ *verify-gpg-signatures* is :unknown-locations
+
+
+= PACKAGE CREATION
+
+If you want to create your own packages that can be installed using this
+loader, see the "Making your package downloadable..." section at
+<http://www.cliki.net/asdf-install>
+
+
+= HACKERS NOTE
+
+Listen very carefully: I will say this only as often as it appears to
+be necessary to say it. asdf-install is not a good example of how to
+write a URL parser, HTTP client, or anything else, really.
+Well-written extensible and robust URL parsers, HTTP clients, FTP
+clients, etc would definitely be nice things to have, but it would be
+nicer to have them in CCLAN where anyone can use them - after having
+downloaded them with asdf-install - than in SBCL contrib where they're
+restricted to SBCL users and can only be updated once a month via SBCL
+developers. This is a bootstrap tool, and as such, will tend to
+resist changes that make it longer or dependent on more other
+packages, unless they also add to its usefulness for bootstrapping.
+
+
+= 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"
+
+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
+
+
Added: trunk/abcl/contrib/asdf-install/RELNOTES
==============================================================================
--- (empty file)
+++ trunk/abcl/contrib/asdf-install/RELNOTES Sat Feb 20 07:04:14 2010
@@ -0,0 +1,5 @@
+12 Sept 2006 gwking at metabang.com
+
+ * added :where parameter to install
+ * now uses more tempoary files
+ * changed selection of locations - 0 is always abort, can use symbols / strings
Added: trunk/abcl/contrib/asdf-install/asdf-install.asd
==============================================================================
--- (empty file)
+++ trunk/abcl/contrib/asdf-install/asdf-install.asd Sat Feb 20 07:04:14 2010
@@ -0,0 +1,52 @@
+;;; -*- Lisp -*-
+
+;;; Portatble ASDF-Install is based on Dan Barlow's ASDF-Install
+;; (see the file COPYRIGHT for details). It is currently maintained
+;; by Gary King <gwking at metabang.com>.
+
+(defpackage #:asdf-install-system
+ (:use #:cl #:asdf))
+
+(in-package #:asdf-install-system)
+
+(defsystem asdf-install
+ #+:sbcl :depends-on
+ #+:sbcl (sb-bsd-sockets)
+ :version "0.6.10-ABCL.0"
+ :author "Dan Barlow <dan at telent.net>, Edi Weitz <edi at agharta.de> and many others. See the file COPYRIGHT for more details."
+ :maintainer "Gary Warren King <gwking at metabang.com>"
+ :components ((:file "defpackage")
+ (:file "split-sequence" :depends-on ("defpackage"))
+
+ (:file "port" :depends-on ("defpackage" "split-sequence"))
+ #+:digitool
+ (:file "digitool" :depends-on ("port"))
+
+ (:file "conditions" :depends-on ("defpackage" "variables"))
+ (:file "variables" :depends-on ("port"))
+ (:file "installer"
+ :depends-on ("port" "split-sequence"
+ #+:digitool "digitool"
+ "conditions" "variables"))
+ (:file "deprecated" :depends-on ("installer")))
+ :in-order-to ((test-op (load-op test-asdf-install)))
+ :perform (test-op :after (op c)
+ (funcall
+ (intern (symbol-name '#:run-tests) :lift)
+ :config :generic)))
+
+(defmethod perform :after ((o load-op) (c (eql (find-system :asdf-install))))
+ (let ((show-version (find-symbol
+ (symbol-name '#:show-version-information)
+ '#:asdf-install)))
+ (when (and show-version (fboundp show-version))
+ (funcall show-version)))
+ (provide 'asdf-install))
+
+(defmethod operation-done-p
+ ((o test-op) (c (eql (find-system :asdf-install))))
+ nil)
+
+#+(or)
+(defmethod perform ((o test-op) (c (eql (find-system :asdf-install))))
+ t)
Added: trunk/abcl/contrib/asdf-install/conditions.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/contrib/asdf-install/conditions.lisp Sat Feb 20 07:04:14 2010
@@ -0,0 +1,82 @@
+(in-package #:asdf-install)
+
+(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)))))
+
+(define-condition gpg-error (error)
+ ((message :initarg :message :reader gpg-error-message))
+ (:report (lambda (c s)
+ (format s "GPG failed with error status:~%~S"
+ (gpg-error-message c)))))
+
+(define-condition gpg-shell-error (gpg-error)
+ ()
+ (:report (lambda (c s)
+ (declare (ignore c))
+ (format s "Call to GPG failed. Perhaps GPG is not installed or not ~
+in the path."))))
+
+(define-condition no-signature (gpg-error) ())
+
+(define-condition key-not-found (gpg-error)
+ ((key-id :initarg :key-id :reader key-id))
+ (:report (lambda (c s)
+ (let* ((*print-circle* nil)
+ (key-id (key-id c))
+ (key-id (if (and (consp key-id)
+ (> (length key-id) 1))
+ (car key-id) key-id)))
+ (format s "~&No key found for key id 0x~A.~%" key-id)
+ (format s "~&Try some command like ~% gpg --recv-keys 0x~A"
+ (format nil "~a" key-id))))))
+
+(define-condition key-not-trusted (gpg-error)
+ ((key-id :initarg :key-id :reader key-id)
+ (key-user-name :initarg :key-user-name :reader key-user-name))
+ (:report (lambda (c s)
+ (format s "GPG warns that the key id 0x~A (~A) is not fully trusted"
+ (key-id c) (key-user-name c)))))
+
+(define-condition author-not-trusted (gpg-error)
+ ((key-id :initarg :key-id :reader key-id)
+ (key-user-name :initarg :key-user-name :reader key-user-name))
+ (:report (lambda (c s)
+ (format s "~A (key id ~A) is not on your package supplier list"
+ (key-user-name c) (key-id c)))))
+
+(define-condition installation-abort (condition)
+ ()
+ (:report (lambda (c s)
+ (declare (ignore c))
+ (installer-msg s "Installation aborted."))))
+
+(defun report-valid-preferred-locations (stream &optional attempted-location)
+ (when attempted-location
+ (installer-msg stream "~s is not a valid value for *preferred-location*"
+ attempted-location))
+ (installer-msg stream "*preferred-location* may either be nil, a number between 1 and ~d \(the length of *locations*\) or the name of one of the *locations* \(~{~s~^, ~}\). If using a name, then it can be a symbol tested with #'eq or a string tested with #'string-equal."
+ (length *locations*)
+ (mapcar #'third *locations*)))
+
+(define-condition invalid-preferred-location-error (error)
+ ((preferred-location :initarg :preferred-location))
+ (:report (lambda (c s)
+ (report-valid-preferred-locations
+ s (slot-value c 'preferred-location)))))
+
+(define-condition invalid-preferred-location-number-error
+ (invalid-preferred-location-error) ())
+
+(define-condition invalid-preferred-location-name-error
+ (invalid-preferred-location-error) ())
+
Added: trunk/abcl/contrib/asdf-install/dead-letter.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/contrib/asdf-install/dead-letter.lisp Sat Feb 20 07:04:14 2010
@@ -0,0 +1,34 @@
+;;;; dead letter
+
+#+Old
+(defun load-system-definition (sysfile)
+ (declare (type pathname sysfile))
+ #+asdf
+ (when (or (string-equal "asd" (pathname-type sysfile))
+ (string-equal "asdf" (pathname-type sysfile)))
+ (installer-msg t "Loading system ~S via ASDF." (pathname-name sysfile))
+ ;; just load the system definition
+ (load sysfile)
+ #+Ignore
+ (asdf:operate 'asdf:load-op (pathname-name sysfile)))
+
+ #+mk-defsystem
+ (when (string-equal "system" (pathname-type sysfile))
+ (installer-msg t "Loading system ~S via MK:DEFSYSTEM." (pathname-name sysfile))
+ (mk:load-system (pathname-name sysfile))))
+
+#+Old
+;; from download-files-for-package
+(with-open-file
+ #-(and allegro-version>= (not (version>= 8 0)))
+ (o file-name :direction :output
+ #+(or :clisp :digitool (and :lispworks :win32))
+ :element-type
+ #+(or :clisp :digitool (and :lispworks :win32))
+ '(unsigned-byte 8)
+ #+:sbcl #+:sbcl :external-format :latin1
+ :if-exists :supersede)
+ ;; for Allegro versions < 8.0, the above #+sbcl #+sbcl
+ ;; will cause an error [2006/01/09:rpg]
+ #+(and allegro-version>= (not (version>= 8 0)))
+ (o file-name :direction :output :if-exists :supersede))
\ No newline at end of file
Added: trunk/abcl/contrib/asdf-install/defpackage.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/contrib/asdf-install/defpackage.lisp Sat Feb 20 07:04:14 2010
@@ -0,0 +1,59 @@
+(cl:in-package :cl-user)
+
+(defpackage #:asdf-install
+ (:use #:common-lisp)
+
+ #+asdf
+ (:import-from #:asdf #:*defined-systems*)
+ (:export
+
+ ;; Customizable variables.
+ #:*shell-path*
+ #:*proxy*
+ #:*cclan-mirror*
+ #:asdf-install-dirs
+ #:private-asdf-install-dirs
+ #:*tar-extractors*
+
+ #:*shell-search-paths*
+ #:*verify-gpg-signatures*
+ #:*locations*
+ #:*safe-url-prefixes*
+ #:*preferred-location*
+ #:*temporary-directory*
+
+ ;; External entry points.
+ #:add-locations
+ #:add-registry-location
+ #:uninstall
+ #:install
+ #:asdf-install-version
+
+ #+(and asdf (or :win32 :mswindows))
+ #:sysdef-source-dir-search
+
+ ;; proxy authentication
+ #:*proxy-user*
+ #:*proxy-passwd*
+
+ ;; conditions
+ #:download-error
+ #:signature-error
+ #:gpg-error
+ #:gpg-shell-error
+ #:key-not-found
+ #:key-not-trusted
+ #:author-not-trusted
+ #:installation-abort
+
+ ;; restarts
+ #:install-anyways
+ )
+
+ #+(or :win32 :mswindows)
+ (:export
+ #:*cygwin-bin-directory*
+ #:*cygwin-bash-command*))
+
+(defpackage #:asdf-install-customize
+ (:use #:common-lisp #:asdf-install))
Added: trunk/abcl/contrib/asdf-install/deprecated.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/contrib/asdf-install/deprecated.lisp Sat Feb 20 07:04:14 2010
@@ -0,0 +1,216 @@
+(in-package asdf-install)
+
+#+(and ignore sbcl) ; Deprecated.
+(define-symbol-macro *sbcl-home* *asdf-install-dirs*)
+
+#+(and ignore sbcl) ; Deprecated.
+(define-symbol-macro *dot-sbcl* *private-asdf-install-dirs*)
+
+#+(or)
+;; uncalled
+(defun read-until-eof (stream)
+ (with-output-to-string (o)
+ (copy-stream stream o)))
+
+
+#+(or)
+(defun verify-gpg-signature/string (string file-name)
+ (block verify
+ (loop
+ (restart-case
+ (let ((gpg-stream (make-stream-from-gpg-command string file-name))
+ tags)
+ (unwind-protect
+ (loop for l = (read-line gpg-stream nil nil)
+ while l
+ do (print l)
+ when (> (mismatch l "[GNUPG:]") 6)
+ do (destructuring-bind (_ tag &rest data)
+ (split-sequence-if (lambda (x)
+ (find x '(#\Space #\Tab)))
+ l)
+ (declare (ignore _))
+ (pushnew (cons (intern (string-upcase tag) :keyword)
+ data) tags)))
+ (ignore-errors
+ (close gpg-stream)))
+ ;; test that command returned something
+ (unless tags
+ (error 'gpg-shell-error))
+ ;; test for obvious key/sig problems
+ (let ((errsig (header-value :errsig tags)))
+ (and errsig (error 'key-not-found :key-id errsig)))
+ (let ((badsig (header-value :badsig tags)))
+ (and badsig (error 'key-not-found :key-id badsig)))
+ (let* ((good (header-value :goodsig tags))
+ (id (first good))
+ (name (format nil "~{~A~^ ~}" (rest good))))
+ ;; good signature, but perhaps not trusted
+ (restart-case
+ (let ((trusted? (or (header-pair :trust_ultimate tags)
+ (header-pair :trust_fully tags)))
+ (in-list? (assoc id *trusted-uids* :test #'equal)))
+ (cond ((or trusted? in-list?)
+ ;; ok
+ )
+ ((not trusted?)
+ (error 'key-not-trusted :key-user-name name :key-id id))
+ ((not in-list?)
+ (error 'author-not-trusted
+ :key-user-name name :key-id id))
+ (t
+ (error "Boolean logic gone bad. Run for the hills"))))
+ (add-key (&rest rest)
+ :report "Add to package supplier list"
+ (declare (ignore rest))
+ (pushnew (list id name) *trusted-uids*))))
+ (return-from verify t))
+ #+Ignore
+ (install-anyways (&rest rest)
+ :report "Don't check GPG signature for this package"
+ (declare (ignore rest))
+ (return-from verify t))
+ (retry-gpg-check (&rest args)
+ :report "Retry GPG check \(e.g., after downloading the key\)"
+ (declare (ignore args))
+ nil)))))
+
+#+(or)
+(defun verify-gpg-signature/url (url file-name)
+ (block verify
+ (loop
+ (restart-case
+ (when (verify-gpg-signatures-p url)
+ (let ((sig-url (concatenate 'string url ".asc")))
+ (destructuring-bind (response headers stream)
+ (url-connection sig-url)
+ (unwind-protect
+ (flet (#-:digitool
+ (read-signature (data stream)
+ (read-sequence data stream))
+ #+:digitool
+ (read-signature (data stream)
+ (multiple-value-bind (reader arg)
+ (ccl:stream-reader stream)
+ (let ((byte 0))
+ (dotimes (i (length data))
+ (unless (setf byte (funcall reader arg))
+ (error 'download-error :url sig-url
+ :response 200))
+ (setf (char data i) (code-char byte)))))))
+ (if (= response 200)
+ (let ((data (make-string (parse-integer
+ (header-value :content-length headers)
+ :junk-allowed t))))
+ (read-signature data stream)
+ (verify-gpg-signature/string data file-name))
+ (error 'download-error :url sig-url
+ :response response)))
+ (close stream)
+ (return-from verify t)))))
+ (install-anyways (&rest rest)
+ :report "Don't check GPG signature for this package"
+ (declare (ignore rest))
+ (return-from verify t))
+ (retry-gpg-check (&rest args)
+ :report "Retry GPG check \(e.g., after fixing the network connection\)"
+ (declare (ignore args))
+ nil)))))
+
+
+#+(or :sbcl :cmu :scl)
+(defun make-stream-from-gpg-command (string file-name)
+ (#+:sbcl sb-ext:process-output
+ #+(or :cmu :scl) ext:process-output
+ (#+:sbcl sb-ext:run-program
+ #+(or :cmu :scl) ext:run-program
+ "gpg"
+ (list
+ "--status-fd" "1" "--verify" "-"
+ (namestring file-name))
+ :output :stream
+ :error nil
+ #+sbcl :search #+sbcl t
+ :input (make-string-input-stream string)
+ :wait t)))
+
+#+(and :lispworks (not :win32))
+(defun make-stream-from-gpg-command (string file-name)
+ ;; kludge - we can't separate the in and out streams
+ (let ((stream (sys:open-pipe (format nil "echo '~A' | gpg --status-fd 1 --verify - ~A"
+ string
+ (namestring file-name)))))
+ stream))
+
+
+#+(and :lispworks :win32)
+(defun make-stream-from-gpg-command (string file-name)
+ (sys:open-pipe (format nil "gpg --status-fd 1 --verify \"~A\" \"~A\""
+ (make-temp-sig file-name string)
+ (namestring file-name))))
+
+#+(and :clisp (not (or :win32 :cygwin)))
+(defun make-stream-from-gpg-command (string file-name)
+ (let ((stream
+ (ext:run-shell-command (format nil "echo '~A' | gpg --status-fd 1 --verify - ~A"
+ string
+ (namestring file-name))
+ :output :stream
+ :wait nil)))
+ stream))
+
+#+(and :clisp (or :win32 :cygwin))
+(defun make-stream-from-gpg-command (string file-name)
+ (ext:run-shell-command (format nil "gpg --status-fd 1 --verify \"~A\" \"~A\""
+ (make-temp-sig file-name string)
+ (namestring file-name))
+ :output :stream
+ :wait nil))
+
+#+:allegro
+(defun make-stream-from-gpg-command (string file-name)
+ (multiple-value-bind (in-stream out-stream)
+ (excl:run-shell-command
+ #-:mswindows
+ (concatenate 'vector
+ #("gpg" "gpg" "--status-fd" "1" "--verify" "-")
+ (make-sequence 'vector 1
+ :initial-element (namestring file-name)))
+ #+:mswindows
+ (format nil "gpg --status-fd 1 --verify - \"~A\"" (namestring file-name))
+ :input :stream
+ :output :stream
+ :separate-streams t
+ :wait nil)
+ (write-string string in-stream)
+ (finish-output in-stream)
+ (close in-stream)
+ out-stream))
+
+#+:openmcl
+(defun make-stream-from-gpg-command (string file-name)
+ (let ((proc (ccl:run-program "gpg" (list "--status-fd" "1" "--verify" "-" (namestring file-name))
+ :input :stream
+ :output :stream
+ :wait nil)))
+ (write-string string (ccl:external-process-input-stream proc))
+ (close (ccl:external-process-input-stream proc))
+ (ccl:external-process-output-stream proc)))
+
+#+:digitool
+(defun make-stream-from-gpg-command (string file-name)
+ (make-instance 'popen-input-stream
+ :command (format nil "echo '~A' | gpg --status-fd 1 --verify - '~A'"
+ string
+ (system-namestring file-name))))
+
+#+(or)
+(defun make-temp-sig (file-name content)
+ (let ((name (format nil "~A.asc" (namestring (truename file-name)))))
+ (with-open-file (out name
+ :direction :output
+ :if-exists :supersede)
+ (write-string content out))
+ (pushnew name *temporary-files*)
+ name))
+
Added: trunk/abcl/contrib/asdf-install/digitool.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/contrib/asdf-install/digitool.lisp Sat Feb 20 07:04:14 2010
@@ -0,0 +1,230 @@
+;;; -*- package: asdf-install; -*-
+;;;
+;;; Digitool-specific bootstrapping
+;;;
+;;; 2004-01-18 james.anderson at setf.de additions for MCL
+;;; 2008-01-22 added exit-code checks to call-system
+
+(in-package #:asdf-install)
+
+#+:digitool
+(let ((getenv-fn 0)
+ (setenv-fn 0)
+ (unsetenv-fn 0)
+ (popen-fn 0)
+ (pclose-fn 0)
+ (fread-fn 0)
+ (feof-fn 0))
+ (ccl::with-cfstrs ((framework "System.framework"))
+ (let ((err 0)
+ (baseURL nil)
+ (bundleURL nil)
+ (bundle nil))
+ (ccl::rlet ((folder :fsref))
+ ;; Find the folder holding the bundle
+ (setf err (ccl::require-trap traps::_FSFindFolder
+ (ccl::require-trap-constant traps::$kOnAppropriateDisk)
+ (ccl::require-trap-constant traps::$kFrameworksFolderType)
+ t folder))
+ ;; if everything's cool, make a URL for it
+ (when (zerop err)
+ (setf baseURL (ccl::require-trap traps::_CFURLCreateFromFSRef (ccl::%null-ptr) folder)))
+ (if (ccl::%null-ptr-p baseURL)
+ (setf err (ccl::require-trap-constant traps::$coreFoundationUnknownErr))))
+ ;; if everything's cool, make a URL for the bundle
+ (when (zerop err)
+ (setf bundleURL (ccl::require-trap traps::_CFURLCreateCopyAppendingPathComponent (ccl::%null-ptr) baseURL framework nil))
+ (if (ccl::%null-ptr-p bundleURL)
+ (setf err (ccl::require-trap-constant traps::$coreFoundationUnknownErr))))
+ ;; if everything's cool, create it
+ (when (zerop err)
+ (setf bundle (ccl::require-trap traps::_CFBundleCreate (ccl::%null-ptr) bundleURL))
+ (if (ccl::%null-ptr-p bundle)
+ (setf err (ccl::require-trap-constant traps::$coreFoundationUnknownErr))))
+ ;; if everything's cool, load it
+ (when (zerop err)
+ (if (not (ccl::require-trap traps::_CFBundleLoadExecutable bundle))
+ (setf err (ccl::require-trap-constant traps::$coreFoundationUnknownErr))))
+ ;; if there's an error, but we've got a pointer, free it and clear result
+ (when (and (not (zerop err)) (not (ccl::%null-ptr-p bundle)))
+ (ccl::require-trap traps::_CFRelease bundle)
+ (setf bundle nil))
+ ;; free the URLs if here non-null
+ (when (not (ccl::%null-ptr-p bundleURL))
+ (ccl::require-trap traps::_CFRelease bundleURL))
+ (when (not (ccl::%null-ptr-p baseURL))
+ (ccl::require-trap traps::_CFRelease baseURL))
+ (cond (bundle
+ ;; extract the necessary function id's
+ (flet ((get-addr (name)
+ (ccl::with-cfstrs ((c-name name))
+ (let* ((addr (ccl::require-trap traps::_CFBundleGetFunctionPointerForName bundle c-name)))
+ (when (ccl::%null-ptr-p addr)
+ (error "Couldn't resolve address of foreign function ~s" name))
+ (ccl::rlet ((buf :long))
+ (setf (ccl::%get-ptr buf) addr)
+ (ash (ccl::%get-signed-long buf) -2))))))
+ (setf getenv-fn (get-addr "getenv"))
+ (setf setenv-fn (get-addr "setenv"))
+ (setf unsetenv-fn (get-addr "unsetenv"))
+ (setf popen-fn (get-addr "popen"))
+ (setf pclose-fn (get-addr "pclose"))
+ (setf fread-fn (get-addr "fread"))
+ (setf feof-fn (get-addr "feof")))
+ (ccl::require-trap traps::_CFRelease bundle)
+ (setf bundle nil))
+ (t
+ (error "can't resolve core framework entry points.")))))
+
+ (defun ccl::getenv (variable-name)
+ (ccl::with-cstrs ((c-variable-name variable-name))
+ (let* ((env-ptr (ccl::%null-ptr)))
+ (declare (dynamic-extent env-ptr))
+ (ccl::%setf-macptr env-ptr (ccl::ppc-ff-call getenv-fn
+ :address c-variable-name
+ :address))
+ (unless (ccl::%null-ptr-p env-ptr)
+ (ccl::%get-cstring env-ptr)))))
+
+ (defun ccl::setenv (variable-name variable-value)
+ (ccl::with-cstrs ((c-variable-name variable-name)
+ (c-variable-value variable-value))
+ (ccl::ppc-ff-call setenv-fn
+ :address c-variable-name
+ :address c-variable-value
+ :signed-fullword 1
+ :signed-fullword)))
+
+ (defun ccl::unsetenv (variable-name)
+ (ccl::with-cstrs ((c-variable-name variable-name))
+ (ccl::ppc-ff-call unsetenv-fn
+ :address c-variable-name
+ :void)))
+
+ (labels ((fread (fp buffer length)
+ (ccl::ppc-ff-call fread-fn
+ :address buffer
+ :unsigned-fullword 1
+ :unsigned-fullword length
+ :address fp
+ :signed-fullword))
+ (feof-p (fp)
+ (not (zerop (ccl::ppc-ff-call feof-fn
+ :address fp
+ :signed-fullword))))
+ (popen (command)
+ (ccl::with-cstrs ((read "r")
+ (cmd command))
+ (ccl::ppc-ff-call popen-fn
+ :address cmd
+ :address read
+ :address)))
+ (pclose (fp)
+ (ccl::ppc-ff-call pclose-fn
+ :address fp
+ :signed-fullword))
+
+ (fread-decoded (fp io-buffer io-buffer-length string-buffer script)
+ (cond ((feof-p fp)
+ (values nil string-buffer))
+ (t
+ (let ((io-count (fread fp io-buffer io-buffer-length)))
+ (cond ((and io-count (plusp io-count))
+ (if script
+ (multiple-value-bind (chars fatp) (ccl::pointer-char-length io-buffer io-count script)
+ (cond ((not fatp)
+ (ccl::%copy-ptr-to-ivector io-buffer 0 string-buffer 0 io-count))
+ (t
+ (unless (>= (length string-buffer) chars)
+ (setf string-buffer (make-string chars :element-type 'base-character)))
+ (ccl::pointer-to-string-in-script io-buffer string-buffer io-count script)
+ (setf io-count chars))))
+ (ccl::%copy-ptr-to-ivector io-buffer 0 string-buffer 0 io-count))
+ (values io-count string-buffer))
+ (t
+ (values 0 string-buffer))))))))
+
+ (defun ccl::call-system (command)
+ (let* ((script (ccl::default-script nil))
+ (table (ccl::get-char-byte-table script))
+ (result (make-array 128 :element-type 'character :adjustable t :fill-pointer 0))
+ (string-buffer (unless table (make-string 512 :element-type 'base-character)))
+ (io-count 0)
+ (fp (popen command))
+ (exit-code 0))
+ (unless (ccl::%null-ptr-p fp)
+ (unwind-protect
+ (ccl::%stack-block ((io-buffer 512))
+ (loop (multiple-value-setq (io-count string-buffer)
+ (fread-decoded fp io-buffer 512 string-buffer (when table script)))
+ (unless io-count (return))
+ (let ((char #\null))
+ (dotimes (i io-count)
+ (case (setf char (schar string-buffer i))
+ ((#\return #\linefeed) (setf char #\newline)))
+ (vector-push-extend char result)))))
+ (setf exit-code (pclose fp))
+ (setf fp nil))
+ (if (zerop exit-code)
+ (values result 0)
+ (values nil exit-code result)))))
+
+ ;; need a function to avoid both the reader macro and the compiler
+ (setf (symbol-function '%new-ptr) #'ccl::%new-ptr)
+
+ (defclass popen-input-stream (ccl::input-stream)
+ ((io-buffer :initform nil)
+ (fp :initform nil )
+ (string-buffer :initform nil)
+ (length :initform 0)
+ (index :initform 0)
+ (script :initarg :script :initform (ccl::default-script nil)))
+ (:default-initargs :direction :input))
+
+ (defmethod initialize-instance :after ((instance popen-input-stream) &key command)
+ (with-slots (io-buffer string-buffer fp script) instance
+ (setf fp (popen command)
+ io-buffer (%new-ptr 512 nil)
+ string-buffer (make-string 512 :element-type 'base-character))
+ (when script (unless (ccl::get-char-byte-table script) (setf script nil)))))
+
+ (defmethod ccl::stream-close ((stream popen-input-stream))
+ (declare (ignore abort))
+ (with-slots (io-buffer string-buffer fp ccl::direction) stream
+ (when (and fp (not (ccl::%null-ptr-p fp)))
+ (pclose fp)
+ (setf fp nil)
+ (setf ccl::direction :closed)
+ (ccl::disposeptr io-buffer)
+ (setf io-buffer nil))))
+
+ (defmethod stream-element-type ((stream popen-input-stream))
+ 'character)
+
+ (defmethod ccl::stream-tyi ((stream popen-input-stream))
+ ;; despite the decoding provisions, unix input comes with linefeeds
+ ;; and i don't know what decoding one would need.
+ (with-slots (io-buffer fp string-buffer length index script) stream
+ (when fp
+ (when (>= index length)
+ (multiple-value-setq (length string-buffer)
+ (fread-decoded fp io-buffer 512 string-buffer script))
+ (unless (and length (plusp length))
+ (setf length -1)
+ (return-from ccl::stream-tyi nil))
+ (setf index 0))
+ (let ((char (schar string-buffer index)))
+ (incf index)
+ (case char
+ ((#\return #\linefeed) #\newline)
+ (t char))))))
+
+ (defmethod ccl::stream-untyi ((stream popen-input-stream) char)
+ (with-slots (string-buffer length index) stream
+ (unless (and (plusp index) (eql char (schar (decf index) string-buffer)))
+ (error "invalid tyi character: ~s." char))
+ char))
+
+ (defmethod ccl::stream-eofp ((stream popen-input-stream))
+ (with-slots (length) stream
+ (minusp length)))))
Added: trunk/abcl/contrib/asdf-install/installer.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/contrib/asdf-install/installer.lisp Sat Feb 20 07:04:14 2010
@@ -0,0 +1,577 @@
+(in-package #:asdf-install)
+
+(pushnew :asdf-install *features*)
+
+(defun installer-msg (stream format-control &rest format-arguments)
+ (apply #'format stream "~&;;; ASDF-INSTALL: ~@?~%"
+ format-control format-arguments))
+
+(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))
+ *safe-url-prefixes*))
+ (t t))))
+
+(defun same-central-registry-entry-p (a b)
+ (flet ((ensure-string (x)
+ (typecase x
+ (string x)
+ (pathname (namestring (translate-logical-pathname x)))
+ (t nil))))
+ (and (setf a (ensure-string a))
+ (setf b (ensure-string b))
+ a b (string-equal a b))))
+
+(defun add-registry-location (location)
+ (let ((location-directory (pathname-sans-name+type location)))
+ #+asdf
+ (pushnew location-directory
+ asdf:*central-registry*
+ :test #'same-central-registry-entry-p)
+
+ #+mk-defsystem
+ (mk:add-registry-location location-directory)))
+
+;;; Fixing the handling of *LOCATIONS*
+
+(defun add-locations (loc-name site system-site)
+ (declare (type string loc-name)
+ (type pathname site system-site))
+ #+asdf
+ (progn
+ (pushnew site asdf:*central-registry* :test #'equal)
+ (pushnew system-site asdf:*central-registry* :test #'equal))
+
+ #+mk-defsystem
+ (progn
+ (mk:add-registry-location site)
+ (mk:add-registry-location system-site))
+ (setf *locations*
+ (append *locations* (list (list site system-site loc-name)))))
+
+;;;---------------------------------------------------------------------------
+;;; URL handling.
+
+(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 (1+ port-start) :junk-allowed t) 80)))
+
+; This is from Juri Pakaste's <juri at iki.fi> base64.lisp
+(defparameter *encode-table*
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=")
+
+(defun base64-encode (string)
+ (let ((result (make-array
+ (list (* 4 (truncate (/ (+ 2 (length string)) 3))))
+ :element-type 'base-char)))
+ (do ((sidx 0 (+ sidx 3))
+ (didx 0 (+ didx 4))
+ (chars 2 2)
+ (value nil nil))
+ ((>= sidx (length string)) t)
+ (setf value (ash (logand #xFF (char-code (char string sidx))) 8))
+ (dotimes (n 2)
+ (when (< (+ sidx n 1) (length string))
+ (setf value
+ (logior value
+ (logand #xFF (char-code (char string (+ sidx n 1))))))
+ (incf chars))
+ (when (= n 0)
+ (setf value (ash value 8))))
+ (setf (elt result (+ didx 3))
+ (elt *encode-table* (if (> chars 3) (logand value #x3F) 64)))
+ (setf value (ash value -6))
+ (setf (elt result (+ didx 2))
+ (elt *encode-table* (if (> chars 2) (logand value #x3F) 64)))
+ (setf value (ash value -6))
+ (setf (elt result (+ didx 1))
+ (elt *encode-table* (logand value #x3F)))
+ (setf value (ash value -6))
+ (setf (elt result didx)
+ (elt *encode-table* (logand value #x3F))))
+ result))
+
+(defun request-uri (url)
+ (assert (string-equal url "http://" :end1 7))
+ (if *proxy*
+ url
+ (let ((path-start (position #\/ url :start 7)))
+ (assert (and path-start) nil "url does not specify a file.")
+ (subseq url path-start))))
+
+(defun url-connection (url)
+ (let ((stream (make-stream-from-url (or *proxy* url)))
+ (host (url-host url)))
+ (format stream "GET ~A HTTP/1.0~C~CHost: ~A~C~CCookie: CCLAN-SITE=~A~C~C"
+ (request-uri url) #\Return #\Linefeed
+ host #\Return #\Linefeed
+ *cclan-mirror* #\Return #\Linefeed)
+ (when (and *proxy-passwd* *proxy-user*)
+ (format stream "Proxy-Authorization: Basic ~A~C~C"
+ (base64-encode (format nil "~A:~A" *proxy-user* *proxy-passwd*))
+ #\Return #\Linefeed))
+ (format stream "~C~C" #\Return #\Linefeed)
+ (force-output stream)
+ (list
+ (let* ((l (read-header-line stream))
+ (space (position #\Space l)))
+ (parse-integer l :start (1+ space) :junk-allowed t))
+ (loop for line = (read-header-line stream)
+ until (or (null line)
+ (zerop (length 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-link-for-package (package-name-or-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)))
+
+(defun download-link-for-signature (url)
+ (concatenate 'string url ".asc"))
+
+(defun download-files-for-package (package-name-or-url)
+ (multiple-value-bind (package-url package-file)
+ (download-url-to-temporary-file
+ (download-link-for-package package-name-or-url))
+ (if (verify-gpg-signatures-p package-name-or-url)
+ (multiple-value-bind (signature-url signature-file)
+ (download-url-to-temporary-file
+ (download-link-for-signature package-url))
+ (declare (ignore signature-url))
+ (values package-file signature-file))
+ (values package-file nil))))
+
+(defun verify-gpg-signature (file-name signature-name)
+ (block verify
+ (loop
+ (restart-case
+ (let ((tags (gpg-results file-name signature-name)))
+ ;; test that command returned something
+ (unless tags
+ (error 'gpg-shell-error))
+ ;; test for obvious key/sig problems
+ (let ((errsig (header-value :errsig tags)))
+ (and errsig (error 'key-not-found :key-id errsig)))
+ (let ((badsig (header-value :badsig tags)))
+ (and badsig (error 'key-not-found :key-id badsig)))
+ (let* ((good (header-value :goodsig tags))
+ (id (first good))
+ (name (format nil "~{~A~^ ~}" (rest good))))
+ ;; good signature, but perhaps not trusted
+ (restart-case
+ (let ((trusted? (or (header-pair :trust_ultimate tags)
+ (header-pair :trust_fully tags)))
+ (in-list? (assoc id *trusted-uids* :test #'equal)))
+ (cond ((or trusted? in-list?)
+ ;; ok
+ )
+ ((not trusted?)
+ (error 'key-not-trusted
+ :key-user-name name :key-id id))
+ ((not in-list?)
+ (error 'author-not-trusted
+ :key-user-name name :key-id id))))
+ (add-key (&rest rest)
+ :report "Add to package supplier list"
+ (declare (ignore rest))
+ (pushnew (list id name) *trusted-uids*))))
+ (return-from verify t))
+ (install-anyways
+ (&rest rest)
+ :report "Don't check GPG signature for this package"
+ (declare (ignore rest))
+ (return-from verify t))
+ (retry-gpg-check
+ (&rest args)
+ :report "Retry GPG check \(e.g., after downloading the key\)"
+ (declare (ignore args))
+ nil)))))
+
+(defun header-value (name headers)
+ "Searchers headers for name _without_ case sensitivity. Headers should be an alist mapping symbols to values; name a symbol. Returns the value if name is found or nil if it is not."
+ (cdr (header-pair name headers)))
+
+(defun header-pair (name headers)
+ "Searchers headers for name _without_ case sensitivity. Headers should be an alist mapping symbols to values; name a symbol. Returns the \(name value\) pair if name is found or nil if it is not."
+ (assoc name headers
+ :test (lambda (a b)
+ (string-equal (symbol-name a) (symbol-name b)))))
+
+(defun validate-preferred-location ()
+ (typecase *preferred-location*
+ (null t)
+ ((integer 0)
+ (assert (<= 1 *preferred-location* (length *locations*))
+ (*preferred-location*)
+ 'invalid-preferred-location-number-error
+ :preferred-location *preferred-location*))
+ ((or symbol string)
+ (assert (find *preferred-location* *locations*
+ :test (if (typep *preferred-location* 'symbol)
+ #'eq #'string-equal) :key #'third)
+ (*preferred-location*)
+ 'invalid-preferred-location-name-error
+ :preferred-location *preferred-location*))
+ (t
+ (assert nil
+ (*preferred-location*)
+ 'invalid-preferred-location-error
+ :preferred-location *preferred-location*)))
+ *preferred-location*)
+
+(defun select-location ()
+ (loop with n-locations = (length *locations*)
+ for response = (progn
+ (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 "0) Abort installation.~% --> ")
+ (force-output)
+ (read))
+ when (and (numberp response)
+ (<= 1 response n-locations))
+ return response
+ when (and (numberp response)
+ (zerop response))
+ do (abort (make-condition 'installation-abort))))
+
+(defun install-location ()
+ (validate-preferred-location)
+ (let ((location-selection (or *preferred-location*
+ (select-location))))
+ (etypecase location-selection
+ (integer
+ (elt *locations* (1- location-selection)))
+ ((or symbol string)
+ (find location-selection *locations* :key #'third
+ :test (if (typep location-selection 'string)
+ #'string-equal #'eq))))))
+
+
+;;; install-package --
+
+(defun find-shell-command (command)
+ (loop for directory in *shell-search-paths* do
+ (let ((target (make-pathname :name command :type nil
+ :directory directory)))
+ (when (probe-file target)
+ (return-from find-shell-command (namestring target)))))
+ (values nil))
+
+(defun tar-command ()
+ #-(or :win32 :mswindows)
+ (find-shell-command *gnu-tar-program*)
+ #+(or :win32 :mswindows)
+ *cygwin-bash-program*)
+
+(defun tar-arguments (source packagename)
+ #-(or :win32 :mswindows :scl)
+ (list "-C" (namestring (truename source))
+ "-xzvf" (namestring (truename packagename)))
+ #+(or :win32 :mswindows)
+ (list "-l"
+ "-c"
+ (format nil "\"tar -C \\\"`cygpath '~A'`\\\" -xzvf \\\"`cygpath '~A'`\\\"\""
+ (namestring (truename source))
+ (namestring (truename packagename))))
+ #+scl
+ (list "-C" (ext:unix-namestring (truename source))
+ "-xzvf" (ext:unix-namestring (truename packagename))))
+
+(defun extract-using-tar (to-dir tarball)
+ (let ((tar-command (tar-command)))
+ (if (and tar-command (probe-file tar-command))
+ (return-output-from-program tar-command
+ (tar-arguments to-dir tarball))
+ (warn "Cannot find tar command ~S." tar-command))))
+
+(defun extract (to-dir tarball)
+ (or (some #'(lambda (extractor) (funcall extractor to-dir tarball))
+ *tar-extractors*)
+ (error "Unable to extract tarball ~A." tarball)))
+
+(defun install-package (source system packagename)
+ "Returns a list of system names (ASDF or MK:DEFSYSTEM) for installed systems."
+ (ensure-directories-exist source)
+ (ensure-directories-exist system)
+ (let* ((tar (extract source packagename))
+ ;; Some tar programs (OSX) list entries with preceeding "x "
+ ;; as in "x entry/file.asd"
+ (pos-begin (if (= (search "x " tar) 0)
+ 2
+ 0))
+ (pos-slash (or (position #\/ tar)
+ (position #\Return tar)
+ (position #\Linefeed tar)))
+ (*default-pathname-defaults*
+ (merge-pathnames
+ (make-pathname :directory
+ `(:relative ,(subseq tar pos-begin pos-slash)))
+ source)))
+ ;(princ tar)
+ (loop for sysfile in (append
+ (directory
+ (make-pathname :defaults *default-pathname-defaults*
+ :name :wild
+ :type "asd"))
+ (directory
+ (make-pathname :defaults *default-pathname-defaults*
+ :name :wild
+ :type "system")))
+ do (maybe-symlink-sysfile system sysfile)
+ do (installer-msg t "Found system definition: ~A" sysfile)
+ do (maybe-update-central-registry sysfile)
+ collect sysfile)))
+
+(defun maybe-update-central-registry (sysfile)
+ ;; make sure that the systems we install are accessible in case
+ ;; asdf-install:*locations* and asdf:*central-registry* are out
+ ;; of sync
+ (add-registry-location sysfile))
+
+(defun temp-file-name (p)
+ (declare (ignore p))
+ (let ((pathname nil))
+ (loop for i = 0 then (1+ i) do
+ (setf pathname
+ (merge-pathnames
+ (make-pathname
+ :name (format nil "asdf-install-~d" i)
+ :type "asdf-install-tmp")
+ *temporary-directory*))
+ (unless (probe-file pathname)
+ (return-from temp-file-name pathname)))))
+
+
+;;; install
+;;; This is the external entry point.
+
+(defun install (packages &key (propagate nil) (where *preferred-location*))
+ (let* ((*preferred-location* where)
+ (*temporary-files* nil)
+ (trusted-uid-file
+ (merge-pathnames "trusted-uids.lisp" *private-asdf-install-dirs*))
+ (*trusted-uids*
+ (when (probe-file trusted-uid-file)
+ (with-open-file (f trusted-uid-file) (read f))))
+ (old-uids (copy-list *trusted-uids*))
+ #+asdf
+ (*defined-systems* (if propagate
+ (make-hash-table :test 'equal)
+ *defined-systems*))
+ (packages (if (atom packages) (list packages) packages))
+ (*propagate-installation* propagate)
+ (*systems-installed-this-time* nil))
+ (unwind-protect
+ (destructuring-bind (source system name) (install-location)
+ (declare (ignore name))
+ (labels
+ ((one-iter (packages)
+ (let ((packages-to-install nil))
+ (loop for p in (mapcar #'string packages) do
+ (cond ((local-archive-p p)
+ (setf packages-to-install
+ (append packages-to-install
+ (install-package source system p))))
+ (t
+ (multiple-value-bind (package signature)
+ (download-files-for-package p)
+ (when (verify-gpg-signatures-p p)
+ (verify-gpg-signature package signature))
+ (installer-msg t "Installing ~A in ~A, ~A"
+ p source system)
+ (install-package source system package))
+ (setf packages-to-install
+ (append packages-to-install
+ (list p))))))
+ (dolist (package packages-to-install)
+ (setf package
+ (etypecase package
+ (symbol package)
+ (string (intern package :asdf-install))
+ (pathname (intern
+ (namestring (pathname-name package))
+ :asdf-install))))
+ (handler-bind
+ (
+ #+asdf
+ (asdf:missing-dependency
+ (lambda (c)
+ (installer-msg
+ t
+ "Downloading package ~A, required by ~A~%"
+ (asdf::missing-requires c)
+ (asdf:component-name
+ (asdf::missing-required-by c)))
+ (one-iter
+ (list (asdf::coerce-name
+ (asdf::missing-requires c))))
+ (invoke-restart 'retry)))
+ #+mk-defsystem
+ (make:missing-component
+ (lambda (c)
+ (installer-msg
+ t
+ "Downloading package ~A, required by ~A~%"
+ (make:missing-component-name c)
+ package)
+ (one-iter (list (make:missing-component-name c)))
+ (invoke-restart 'retry))))
+ (loop (multiple-value-bind (ret restart-p)
+ (with-simple-restart
+ (retry "Retry installation")
+ (push package *systems-installed-this-time*)
+ (load-package package))
+ (declare (ignore ret))
+ (unless restart-p (return)))))))))
+ (one-iter packages)))
+ ;;; cleanup
+ (unless (equal old-uids *trusted-uids*)
+ (let ((create-file-p nil))
+ (unless (probe-file trusted-uid-file)
+ (installer-msg t "Trusted UID file ~A does not exist"
+ (namestring trusted-uid-file))
+ (setf create-file-p
+ (y-or-n-p "Do you want to create the file?")))
+ (when (or create-file-p (probe-file trusted-uid-file))
+ (ensure-directories-exist trusted-uid-file)
+ (with-open-file (out trusted-uid-file
+ :direction :output
+ :if-exists :supersede)
+ (with-standard-io-syntax
+ (prin1 *trusted-uids* out))))))
+ (dolist (l *temporary-files* t)
+ (when (probe-file l) (delete-file l))))
+ (nreverse *systems-installed-this-time*)))
+
+(defun local-archive-p (package)
+ #+(or :sbcl :allegro) (probe-file package)
+ #-(or :sbcl :allegro) (and (/= (mismatch package "http://") 7)
+ (probe-file package)))
+
+(defun load-package (package)
+ #+asdf
+ (progn
+ (installer-msg t "Loading system ~S via ASDF." package)
+ (asdf:operate 'asdf:load-op package))
+ #+mk-defsystem
+ (progn
+ (installer-msg t "Loading system ~S via MK:DEFSYSTEM." package)
+ (mk:load-system package)))
+
+;;; uninstall --
+
+(defun uninstall (system &optional (prompt t))
+ #+asdf
+ (let* ((asd (asdf:system-definition-pathname system))
+ (system (asdf:find-system system))
+ (dir (pathname-sans-name+type
+ (asdf::resolve-symlinks asd))))
+ (when (or (not prompt)
+ (y-or-n-p
+ "Delete system ~A~%asd file: ~A~%sources: ~A~%Are you sure?"
+ system asd dir))
+ #-(or :win32 :mswindows)
+ (delete-file asd)
+ (let ((dir (#-scl namestring #+scl ext:unix-namestring (truename dir))))
+ (when dir
+ (asdf:run-shell-command "rm -r '~A'" dir)))))
+
+ #+mk-defsystem
+ (multiple-value-bind (sysfile sysfile-exists-p)
+ (mk:system-definition-pathname system)
+ (when sysfile-exists-p
+ (let ((system (ignore-errors (mk:find-system system :error))))
+ (when system
+ (when (or (not prompt)
+ (y-or-n-p
+ "Delete system ~A.~%system file: ~A~%Are you sure?"
+ system
+ sysfile))
+ (mk:clean-system system)
+ (delete-file sysfile)
+ (dolist (f (mk:files-in-system system))
+ (delete-file f)))
+ ))
+ )))
+
+
+;;; some day we will also do UPGRADE, but we need to sort out version
+;;; numbering a bit better first
+
+#+(and :asdf (or :win32 :mswindows))
+(defun sysdef-source-dir-search (system)
+ (let ((name (asdf::coerce-name system)))
+ (dolist (location *locations*)
+ (let* ((dir (first location))
+ (files (directory (merge-pathnames
+ (make-pathname :name name
+ :type "asd"
+ :version :newest
+ :directory '(:relative :wild)
+ :host nil
+ :device nil)
+ dir))))
+ (dolist (file files)
+ (when (probe-file file)
+ (return-from sysdef-source-dir-search file)))))))
+
+(defmethod asdf:find-component :around
+ ((module (eql nil)) name &optional version)
+ (declare (ignore version))
+ (when (or (not *propagate-installation*)
+ (member name *systems-installed-this-time*
+ :test (lambda (a b)
+ (flet ((ensure-string (x)
+ (etypecase x
+ (symbol (symbol-name x))
+ (string x))))
+ (string-equal (ensure-string a) (ensure-string b))))))
+ (call-next-method)))
+
+(defun show-version-information ()
+ (let ((version (asdf-install-version)))
+ (if version
+ (format *standard-output* "~&;;; ASDF-Install version ~A"
+ version)
+ (format *standard-output* "~&;;; ASDF-Install version unknown; unable to find ASDF system definition."))
+ (values)))
+
+(defun asdf-install-version ()
+ "Returns the ASDf-Install version information as a string or nil if it cannot be determined."
+ (let ((system (asdf:find-system 'asdf-install)))
+ (when system (asdf:component-version system))))
+
+;; load customizations if any
+(eval-when (:load-toplevel :execute)
+ (let* ((*package* (find-package :asdf-install-customize))
+ (file (probe-file (merge-pathnames
+ (make-pathname :name ".asdf-install")
+ (truename (user-homedir-pathname))))))
+ (when file (load file))))
+
+;;; end of file -- install.lisp --
Added: trunk/abcl/contrib/asdf-install/lift-standard.config
==============================================================================
--- (empty file)
+++ trunk/abcl/contrib/asdf-install/lift-standard.config Sat Feb 20 07:04:14 2010
@@ -0,0 +1,38 @@
+;;; configuration for LIFT tests
+
+;; settings
+(:if-dribble-exists :supersede)
+(:dribble "asdf-install.dribble")
+(:print-length 10)
+(:print-level 5)
+(:print-test-case-names t)
+
+;; suites to run
+(test-asdf-install)
+
+;; report properties
+(:report-property :title "ASDF-Install | Test results")
+(:report-property :relative-to test-asdf-install)
+
+
+
+(:report-property :style-sheet "test-style.css")
+(:report-property :if-exists :supersede)
+(:report-property :format :html)
+(:report-property :name "test-results/test-report.html")
+(:report-property :unique-name t)
+(:build-report)
+
+(:report-property :unique-name t)
+(:report-property :format :describe)
+(:report-property :name "test-results/test-report.txt")
+(:build-report)
+
+
+(:report-property :format :save)
+(:report-property :name "test-results/test-report.sav")
+(:build-report)
+
+(:report-property :format :describe)
+(:report-property :full-pathname *standard-output*)
+(:build-report)
Added: trunk/abcl/contrib/asdf-install/load-asdf-install.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/contrib/asdf-install/load-asdf-install.lisp Sat Feb 20 07:04:14 2010
@@ -0,0 +1,90 @@
+;;; -*- Mode: Lisp -*-
+
+;;; load-asdf-install.lisp --
+;;; Generic loader for ASDF-INSTALL.
+
+(eval-when (:load-toplevel :execute)
+ (unless (find-package '#:asdf-install-loader)
+ (make-package '#:asdf-install-loader :use '(#:common-lisp))))
+
+(in-package :asdf-install-loader)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *asdf-install-directory*
+ (make-pathname :host (pathname-host *load-truename*)
+ :device (pathname-device *load-truename*)
+ :directory (pathname-directory *load-truename*)
+ ;; :case :common ; Do we need this?
+ )))
+
+
+(defun cl-user::load-asdf-install
+ (&key
+ (directory *asdf-install-directory*)
+ (compile-first-p nil)
+ (load-verbose *load-verbose*)
+ (print-herald t)
+ )
+ (when print-herald
+ (format *standard-output*
+ "~&;;; ASDF-INSTALL: Loading ASDF-INSTALL package from directory~@
+ ;;; \"~A\"~2%"
+ (namestring (pathname directory))))
+ (let ((directory (pathname directory)))
+ (flet ((load-and-or-compile (file)
+ (if compile-first-p
+ (multiple-value-bind (output-truename warnings-p failure-p)
+ (compile-file file)
+ ;; (declare (ignore warnings-p))
+ (when failure-p
+ (format *standard-output*
+ ";;; File ~S compiled~@
+ ;;; Warnings ~S, Failure ~S.~%"
+ output-truename
+ warnings-p
+ failure-p)
+ (return-from cl-user::load-asdf-install nil)
+ )
+ (load output-truename :verbose load-verbose))
+ (load file :verbose load-verbose)))
+ )
+
+ (setf (logical-pathname-translations "ASDF-INSTALL-LIBRARY")
+ `(("**;*.*.*"
+ ,(make-pathname
+ :host (pathname-host directory)
+ :device (pathname-device directory)
+ :directory (append (pathname-directory directory)
+ (list :wild-inferiors))))
+ ("**;*.*"
+ ,(make-pathname
+ :host (pathname-host directory)
+ :device (pathname-device directory)
+ :directory (append (pathname-directory directory)
+ (list :wild-inferiors))))))
+
+ (load-and-or-compile "ASDF-INSTALL-LIBRARY:defpackage.lisp")
+ (load-and-or-compile "ASDF-INSTALL-LIBRARY:port.lisp")
+
+ (unless (find-package '#:split-sequence)
+ (load-and-or-compile "ASDF-INSTALL-LIBRARY:split-sequence.lisp"))
+
+ (load-and-or-compile "ASDF-INSTALL-LIBRARY:installer.lisp")
+
+ ;; (load-and-or-compile "ASDF-INSTALL-LIBRARY:loader.lisp")
+
+ ))
+ (pushnew :asdf-install *features*)
+ (provide 'asdf-install)
+
+ ;; To clean a minimum (and to make things difficult to debug)...
+ ;; (delete-package '#:asdf-install-loader)
+ )
+
+
+;;; Automatically load the library.
+
+(eval-when (:load-toplevel :execute)
+ (cl-user::load-asdf-install))
+
+;;; end of file -- load-asdf-install.lisp --
Added: trunk/abcl/contrib/asdf-install/loader.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/contrib/asdf-install/loader.lisp Sat Feb 20 07:04:14 2010
@@ -0,0 +1,20 @@
+(in-package :cl-user)
+
+(eval-when (:load-toplevel)
+ (unless (find-package 'asdf)
+ (require 'asdf)))
+
+(eval-when (:load-toplevel)
+ (unless (find-package 'asdf)
+ (error "ASDF-Install requires ASDF to load"))
+ (let ((asdf::*verbose-out* nil))
+ (require 'asdf-install)))
+
+#+sbcl
+(defun run ()
+ (handler-case
+ (apply #'asdf-install:install (cdr *posix-argv*))
+ (error (c)
+ (format *error-output* "Install failed due to error:~% ~A~%" c)
+ (sb-ext:quit :unix-status 1))))
+
Added: trunk/abcl/contrib/asdf-install/port.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/contrib/asdf-install/port.lisp Sat Feb 20 07:04:14 2010
@@ -0,0 +1,516 @@
+(in-package #:asdf-install)
+
+(defvar *temporary-files*)
+
+(defparameter *shell-path* "/bin/sh"
+ "The path to a Bourne compatible command shell in physical pathname notation.")
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
+ #+:allegro
+ (require :osi)
+ #+:allegro
+ (require :socket)
+ #+:digitool
+ (require :opentransport)
+ #+:ecl
+ (require :sockets)
+ #+:lispworks
+ (require "comm")
+ )
+
+(defun get-env-var (name)
+ #+:allegro (sys:getenv name)
+ #+:clisp (ext:getenv name)
+ #+:cmu (cdr (assoc (intern (substitute #\_ #\- name)
+ :keyword)
+ ext:*environment-list*))
+ #+:ecl (ext:getenv name)
+ #+:lispworks (lw:environment-variable name)
+ #+(or :mcl :openmcl) (ccl::getenv name)
+ #+:sbcl (sb-ext:posix-getenv name)
+ #+:scl (cdr (assoc name ext:*environment-list* :test #'string=))
+ #+abcl (ext:getenv name)
+ )
+
+#-:digitool
+(defun system-namestring (pathname)
+ (namestring (truename pathname)))
+
+#+:digitool
+(defvar *start-up-volume*
+ (second (pathname-directory (truename "ccl:"))))
+
+#+:digitool
+(defun system-namestring (pathname)
+ ;; this tries to adjust the root directory to eliminate the spurious
+ ;; volume name for the boot file system; it also avoids use of
+ ;; TRUENAME as some applications are for not yet existent files
+ (let ((truename (probe-file pathname)))
+ (unless truename
+ (setf truename
+ (translate-logical-pathname
+ (merge-pathnames pathname *default-pathname-defaults*))))
+ (let ((directory (pathname-directory truename)))
+ (flet ((string-or-nil (value) (when (stringp value) value))
+ (absolute-p (directory) (eq (first directory) :absolute))
+ (root-volume-p (directory)
+ (equal *start-up-volume* (second directory))))
+ (format nil "~:[~;/~]~{~a/~}~@[~a~]~@[.~a~]"
+ (absolute-p directory)
+ (if (root-volume-p directory) (cddr directory) (cdr directory))
+ (string-or-nil (pathname-name truename))
+ (string-or-nil (pathname-type truename)))))))
+
+#+:digitool
+(progn
+ (defun |read-linefeed-eol-comment|
+ (stream char &optional (eol '(#\return #\linefeed)))
+ (loop (setf char (read-char stream nil nil))
+ (unless char (return))
+ (when (find char eol) (return)))
+ (values))
+
+ (set-syntax-from-char #\linefeed #\space)
+ (set-macro-character #\; #'|read-linefeed-eol-comment| nil *readtable*))
+
+;; for non-SBCL we just steal this from SB-EXECUTABLE
+#-(or :digitool)
+(defvar *stream-buffer-size* 8192)
+#-(or :digitool)
+(defun copy-stream (from to)
+ "Copy into TO from FROM until end of the input stream, in blocks of
+*stream-buffer-size*. The streams should have the same element type."
+ (unless (subtypep (stream-element-type to) (stream-element-type from))
+ (error "Incompatible streams ~A and ~A." from to))
+ (let ((buf (make-array *stream-buffer-size*
+ :element-type (stream-element-type from))))
+ (loop
+ (let ((pos #-(or :clisp :cmu) (read-sequence buf from)
+ #+:clisp (ext:read-byte-sequence buf from :no-hang nil)
+ #+:cmu (sys:read-n-bytes from buf 0 *stream-buffer-size* nil)))
+ (when (zerop pos) (return))
+ (write-sequence buf to :end pos)))))
+
+#+:digitool
+(defun copy-stream (from to)
+ "Perform copy and map EOL mode."
+ (multiple-value-bind (reader reader-arg) (ccl::stream-reader from)
+ (multiple-value-bind (writer writer-arg) (ccl::stream-writer to)
+ (let ((datum nil))
+ (loop (unless (setf datum (funcall reader reader-arg))
+ (return))
+ (funcall writer writer-arg datum))))))
+
+(defun make-stream-from-url (url)
+ #+(or :sbcl :ecl)
+ (let ((s (make-instance 'sb-bsd-sockets:inet-socket
+ :type :stream
+ :protocol :tcp)))
+ (sb-bsd-sockets:socket-connect
+ s (car (sb-bsd-sockets:host-ent-addresses
+ (sb-bsd-sockets:get-host-by-name (url-host url))))
+ (url-port url))
+ (sb-bsd-sockets:socket-make-stream
+ s
+ :input t
+ :output t
+ :buffering :full
+ :external-format :iso-8859-1))
+ #+:cmu
+ (sys:make-fd-stream (ext:connect-to-inet-socket (url-host url) (url-port url))
+ :input t :output t :buffering :full)
+ #+:scl
+ (sys:make-fd-stream (ext:connect-to-inet-socket (url-host url) (url-port url))
+ :input t :output t :buffering :full
+ :external-format :iso-8859-1)
+ #+:lispworks
+ (comm:open-tcp-stream (url-host url) (url-port url)
+ #+(and :lispworks :win32) :element-type
+ #+(and :lispworks :win32) '(unsigned-byte 8))
+ #+:allegro
+ (socket:make-socket :remote-host (url-host url)
+ :remote-port (url-port url))
+ #+:clisp
+ (socket:socket-connect (url-port url) (url-host url)
+ :external-format
+ (ext:make-encoding :charset 'charset:iso-8859-1 :line-terminator :unix))
+ #+:openmcl
+ (ccl:make-socket :remote-host (url-host url)
+ :remote-port (url-port url))
+ #+:digitool
+ (ccl::open-tcp-stream (url-host url) (url-port url)
+ :element-type 'unsigned-byte)
+
+ #+:abcl
+ (let ((socket
+ (ext:make-socket (url-host url) (url-port url))))
+ (ext:get-socket-stream socket)))
+
+
+#+:sbcl
+(defun return-output-from-program (program args)
+ (with-output-to-string (out-stream)
+ (let ((proc (sb-ext:run-program
+ program
+ args
+ :output out-stream
+ :search t
+ :wait t)))
+ (when (or (null proc)
+ (and (member (sb-ext:process-status proc) '(:exited :signaled))
+ (not (zerop (sb-ext:process-exit-code proc)))))
+ (return-from return-output-from-program nil)))))
+
+#+(or :cmu :scl)
+(defun return-output-from-program (program args)
+ (with-output-to-string (out-stream)
+ (let ((proc (ext:run-program
+ program
+ args
+ :output out-stream
+ :wait t)))
+ (when (or (null proc)
+ (and (member (ext:process-status proc) '(:exited :signaled))
+ (not (zerop (ext:process-exit-code proc)))))
+ (return-from return-output-from-program nil)))))
+
+#+:lispworks
+(defun return-output-from-program (program args)
+ (with-output-to-string (out-stream)
+ (unless (zerop (sys:call-system-showing-output
+ (format nil #-:win32 "~A~{ '~A'~}"
+ #+:win32 "~A~{ ~A~}"
+ program args)
+ :prefix ""
+ :show-cmd nil
+ :output-stream out-stream))
+ (return-from return-output-from-program nil))))
+
+#+(and :clisp (not :win32))
+(defun return-output-from-program (program args)
+ (with-output-to-string (out-stream)
+ (let ((stream
+ (ext:run-program program
+ :arguments args
+ :output :stream
+ :wait nil)))
+ (loop for line = (read-line stream nil)
+ while line
+ do (write-line line out-stream)))))
+
+#+(and :clisp :win32)
+(defun return-output-from-program (program args)
+ (with-output-to-string (out-stream)
+ (let ((stream
+ (ext:run-shell-command
+ (format nil "~A~{ ~A~}" program args
+ :output :stream
+ :wait nil))))
+ (loop for line = (ignore-errors (read-line stream nil))
+ while line
+ do (write-line line out-stream)))))
+
+#+:allegro
+(defun return-output-from-program (program args)
+ (with-output-to-string (out-stream)
+ (let ((stream
+ (excl:run-shell-command
+ #-:mswindows
+ (concatenate 'vector
+ (list program)
+ (cons program args))
+ #+:mswindows
+ (format nil "~A~{ ~A~}" program args)
+ :output :stream
+ :wait nil)))
+ (loop for line = (read-line stream nil)
+ while line
+ do (write-line line out-stream)))))
+
+#+:ecl
+(defun return-output-from-program (program args)
+ (with-output-to-string (out-stream)
+ (let ((stream (ext:run-program program args :output :stream)))
+ (when stream
+ (loop for line = (ignore-errors (read-line stream nil))
+ while line
+ do (write-line line out-stream))))))
+
+#+:openmcl
+(defun return-output-from-program (program args)
+ (with-output-to-string (out-stream)
+ (let ((proc (ccl:run-program program args
+ :input nil
+ :output :stream
+ :wait nil)))
+ (loop for line = (read-line
+ (ccl:external-process-output-stream proc) nil nil nil)
+ while line
+ do (write-line line out-stream)))))
+
+#+:digitool
+(defun return-output-from-program (program args)
+ (ccl::call-system (format nil "~A~{ '~A'~} 2>&1" program args)))
+
+#+:abcl
+(defun return-output-from-program (program args)
+ (let ((command (format nil "~A ~{ '~A' ~}" program args)))
+ (with-output-to-string (out-stream)
+ (ext:run-shell-command command :output out-stream))))
+
+
+(defun unlink-file (pathname)
+ ;; 20070208 gwking at metabang.com - removed lisp-specific os-level calls
+ ;; in favor of a simple delete
+ (delete-file pathname))
+
+(defun symlink-files (old new)
+ (let* ((old (#-scl namestring #+scl ext:unix-namestring old))
+ (new (#-scl namestring #+scl ext:unix-namestring new #+scl nil))
+ ;; 20070811 - thanks to Juan Jose Garcia-Ripoll for pointing
+ ;; that ~a would wreck havoc if the working directory had a space
+ ;; in the pathname
+ (command (format nil "ln -s ~s ~s" old new)))
+ (format t "~S~%" command)
+ (shell-command command)))
+
+(defun maybe-symlink-sysfile (system sysfile)
+ (declare (ignorable system sysfile))
+ #-(or :win32 :mswindows)
+ (let ((target (merge-pathnames
+ (make-pathname :name (pathname-name sysfile)
+ :type (pathname-type sysfile))
+ system)))
+ (when (probe-file target)
+ (unlink-file target))
+ (symlink-files sysfile target)))
+
+;;; ---------------------------------------------------------------------------
+;;; read-header-line
+;;; ---------------------------------------------------------------------------
+
+#-:digitool
+(defun read-header-line (stream)
+ (read-line stream))
+
+#+:digitool
+(defun read-header-line (stream &aux (line (make-array 16
+ :element-type 'character
+ :adjustable t
+ :fill-pointer 0))
+ (byte nil))
+ (print (multiple-value-bind (reader arg)
+ (ccl::stream-reader stream)
+ (loop (setf byte (funcall reader arg))
+ (case byte
+ ((nil)
+ (return))
+ ((#.(char-code #\Return)
+ #.(char-code #\Linefeed))
+ (case (setf byte (funcall reader arg))
+ ((nil #.(char-code #\Return) #.(char-code #\Linefeed)))
+ (t (ccl:stream-untyi stream byte)))
+ (return))
+ (t
+ (vector-push-extend (code-char byte) line))))
+ (when (or byte (plusp (length line)))
+ line))))
+
+(defun open-file-arguments ()
+ (append
+ #+sbcl
+ '(:external-format :latin1)
+ #+:scl
+ '(:external-format :iso-8859-1)
+ #+(or :clisp :digitool (and :lispworks :win32))
+ '(:element-type (unsigned-byte 8))))
+
+(defun download-url-to-file (url file-name)
+ "Resolves url and then downloads it to file-name; returns the url actually used."
+ (multiple-value-bind (response headers stream)
+ (loop
+ (destructuring-bind (response headers stream)
+ (url-connection url)
+ (unless (member response '(301 302))
+ (return (values response headers stream)))
+ (close stream)
+ (setf url (header-value :location headers))))
+ (when (>= response 400)
+ (error 'download-error :url url :response response))
+ (let ((length (parse-integer (or (header-value :content-length headers) "")
+ :junk-allowed t)))
+ (installer-msg t "Downloading ~A bytes from ~A to ~A ..."
+ (or length "some unknown number of")
+ url
+ file-name)
+ (force-output)
+ #+:clisp (setf (stream-element-type stream)
+ '(unsigned-byte 8))
+ (let ((ok? nil) (o nil))
+ (unwind-protect
+ (progn
+ (setf o (apply #'open file-name
+ :direction :output :if-exists :supersede
+ (open-file-arguments)))
+ #+(or :cmu :digitool)
+ (copy-stream stream o)
+ #-(or :cmu :digitool)
+ (if length
+ (let ((buf (make-array length
+ :element-type
+ (stream-element-type stream))))
+ #-:clisp (read-sequence buf stream)
+ #+:clisp (ext:read-byte-sequence buf stream :no-hang nil)
+ (write-sequence buf o))
+ (copy-stream stream o))
+ (setf ok? t))
+ (when o (close o :abort (null ok?))))))
+ (close stream))
+ (values url))
+
+(defun download-url-to-temporary-file (url)
+ "Attempts to download url to a new, temporary file. Returns the resolved url and the file name \(as multiple values\)."
+ (let ((tmp (temp-file-name url)))
+ (pushnew tmp *temporary-files*)
+ (values (download-url-to-file url tmp) tmp)))
+
+(defun gpg-results (package signature)
+ (let ((tags nil))
+ (with-input-from-string
+ (gpg-stream
+ (shell-command (format nil "~s --status-fd 1 --verify ~s ~s"
+ *gpg-command*
+ (namestring signature) (namestring package))))
+ (loop for l = (read-line gpg-stream nil nil)
+ while l
+ do (print l)
+ when (> (mismatch l "[GNUPG:]") 6)
+ do (destructuring-bind (_ tag &rest data)
+ (split-sequence-if (lambda (x)
+ (find x '(#\Space #\Tab)))
+ l)
+ (declare (ignore _))
+ (pushnew (cons (intern (string-upcase tag) :keyword)
+ data) tags)))
+ tags)))
+
+#+allegro
+(defun shell-command (command)
+ (multiple-value-bind (output error status)
+ (excl.osi:command-output command :whole t)
+ (values output error status)))
+
+#+clisp
+(defun shell-command (command)
+ ;; BUG: CLisp doesn't allow output to user-specified stream
+ (values
+ nil
+ nil
+ (ext:run-shell-command command :output :terminal :wait t)))
+
+#+(or :cmu :scl)
+(defun shell-command (command)
+ (let* ((process (ext:run-program
+ *shell-path*
+ (list "-c" command)
+ :input nil :output :stream :error :stream))
+ (output (file-to-string-as-lines (ext::process-output process)))
+ (error (file-to-string-as-lines (ext::process-error process))))
+ (close (ext::process-output process))
+ (close (ext::process-error process))
+ (values
+ output
+ error
+ (ext::process-exit-code process))))
+
+#+ecl
+(defun shell-command (command)
+ ;; If we use run-program, we do not get exit codes
+ (values nil nil (ext:system command)))
+
+#+lispworks
+(defun shell-command (command)
+ ;; BUG: Lispworks combines output and error streams
+ (let ((output (make-string-output-stream)))
+ (unwind-protect
+ (let ((status
+ (system:call-system-showing-output
+ command
+ :prefix ""
+ :show-cmd nil
+ :output-stream output)))
+ (values (get-output-stream-string output) nil status))
+ (close output))))
+
+#+openmcl
+(defun shell-command (command)
+ (let* ((process (create-shell-process command t))
+ (output (file-to-string-as-lines
+ (ccl::external-process-output-stream process)))
+ (error (file-to-string-as-lines
+ (ccl::external-process-error-stream process))))
+ (close (ccl::external-process-output-stream process))
+ (close (ccl::external-process-error-stream process))
+ (values output
+ error
+ (process-exit-code process))))
+
+#+openmcl
+(defun create-shell-process (command wait)
+ (ccl:run-program
+ *shell-path*
+ (list "-c" command)
+ :input nil :output :stream :error :stream
+ :wait wait))
+
+#+openmcl
+(defun process-exit-code (process)
+ (nth-value 1 (ccl:external-process-status process)))
+
+#+digitool
+(defun shell-command (command)
+ ;; BUG: I have no idea what this returns
+ (ccl::call-system command))
+
+#+sbcl
+(defun shell-command (command)
+ (let* ((process (sb-ext:run-program
+ *shell-path*
+ (list "-c" command)
+ :input nil :output :stream :error :stream))
+ (output (file-to-string-as-lines (sb-impl::process-output process)))
+ (error (file-to-string-as-lines (sb-impl::process-error process))))
+ (close (sb-impl::process-output process))
+ (close (sb-impl::process-error process))
+ (values
+ output
+ error
+ (sb-impl::process-exit-code process))))
+
+#+:abcl
+(defun shell-command (command)
+ (let* ((output (make-string-output-stream))
+ (status
+ (ext:run-shell-command command :output output)))
+ (values (get-output-stream-string output) nil (format nil "~A" status))))
+
+(defgeneric file-to-string-as-lines (pathname)
+ (:documentation ""))
+
+(defmethod file-to-string-as-lines ((pathname pathname))
+ (with-open-file (stream pathname :direction :input)
+ (file-to-string-as-lines stream)))
+
+(defmethod file-to-string-as-lines ((stream stream))
+ (with-output-to-string (s)
+ (loop for line = (read-line stream nil :eof nil)
+ until (eq line :eof) do
+ (princ line s)
+ (terpri s))))
+
+;; copied from ASDF
+(defun pathname-sans-name+type (pathname)
+ "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
+and NIL NAME and TYPE components"
+ (make-pathname :name nil :type nil :defaults pathname))
+
Added: trunk/abcl/contrib/asdf-install/split-sequence.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/contrib/asdf-install/split-sequence.lisp Sat Feb 20 07:04:14 2010
@@ -0,0 +1,59 @@
+;;;; SPLIT-SEQUENCE
+;;;
+;;; This code was based on Arthur Lemmens' in
+;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>;
+;;;
+
+(in-package #:asdf-install)
+
+(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
+ "Return a list of subsequences in seq delimited by items satisfying
+predicate.
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded. All other keywords
+work analogously to those for CL:SUBSTITUTE-IF. In particular, the
+behaviour of :from-end is possibly different from other versions of
+this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+ (let ((len (length seq))
+ (other-keys (when key-supplied
+ (list :key key))))
+ (unless end (setq end len))
+ (if from-end
+ (loop for right = end then left
+ for left = (max (or (apply #'position-if predicate seq
+ :end right
+ :from-end t
+ other-keys)
+ -1)
+ (1- start))
+ unless (and (= right (1+ left))
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values (nreverse subseqs) right)
+ else
+ collect (subseq seq (1+ left) right) into subseqs
+ and sum 1 into nr-elts
+ until (< left start)
+ finally (return (values (nreverse subseqs) (1+ left))))
+ (loop for left = start then (+ right 1)
+ for right = (min (or (apply #'position-if predicate seq
+ :start left
+ other-keys)
+ len)
+ end)
+ unless (and (= right left)
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values subseqs left)
+ else
+ collect (subseq seq left right) into subseqs
+ and sum 1 into nr-elts
+ until (>= right end)
+ finally (return (values subseqs right))))))
+
Added: trunk/abcl/contrib/asdf-install/variables.lisp
==============================================================================
--- (empty file)
+++ trunk/abcl/contrib/asdf-install/variables.lisp Sat Feb 20 07:04:14 2010
@@ -0,0 +1,122 @@
+(in-package #:asdf-install)
+
+(defun directorify (name)
+ ;; input name may or may not have a trailing #\/, 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)))
+
+#+:digitool
+(defparameter *home-volume-name*
+ (second (pathname-directory (truename (user-homedir-pathname))))
+ "Digitool MCL retains the OS 9 convention that ALL volumes have a
+name which includes the startup volume. OS X doesn't know about this.
+This figures in the home path and in the normalization for system
+namestrings.")
+
+(defvar *proxy* (get-env-var "http_proxy"))
+
+(defvar *proxy-user* nil)
+
+(defvar *proxy-passwd* nil)
+
+(defvar *trusted-uids* nil)
+
+(defvar *verify-gpg-signatures* t
+ "Can be t, nil, or :unknown-locations. If true, then the signature of all packages will be checked. If nil, then no signatures will be checked. If :unkown-locations, then only packages whose location is not a prefix of any `*safe-url-prefixes*` will be tested.")
+
+(defvar *safe-url-prefixes* nil)
+
+(defvar *preferred-location* nil)
+
+(defvar *cclan-mirror*
+ (or (get-env-var "CCLAN_MIRROR")
+ "http://ftp.linux.org.uk/pub/lisp/cclan/"))
+
+#+(or :win32 :mswindows)
+(defvar *cygwin-bin-directory*
+ (pathname "C:\\PROGRA~1\\Cygwin\\bin\\"))
+
+#+(or :win32 :mswindows)
+(defvar *cygwin-bash-program*
+ "C:\\PROGRA~1\\Cygwin\\bin\\bash.exe")
+
+;; bin first
+(defvar *shell-search-paths* '((:absolute "bin")
+ (:absolute "usr" "bin"))
+ "A list of places to look for shell commands.")
+
+(defvar *gnu-tar-program*
+ #-(or :netbsd :freebsd :solaris) "tar"
+ #+(or :netbsd :freebsd :solaris) "gtar"
+ "Path to the GNU tar program")
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *supported-defsystems*
+ (list :mk-defsystem
+ :asdf
+
+ ;; Add others.
+ ;; #+lispworks :common-defsystem
+ ;; #+gbbopen :mini-module
+ ))
+ (unless (some (lambda (defsys-tag)
+ (member defsys-tag *features*))
+ *features*)
+ (error "ASDF-INSTALL requires one of the following \"defsystem\" utilities to work: ~A"
+ *supported-defsystems*)))
+
+(defvar *asdf-install-dirs*
+ (directorify (or #+sbcl (get-env-var "SBCL_HOME")
+ (get-env-var "ASDF_INSTALL_DIR")
+ (make-pathname :directory
+ `(:absolute
+ #+digitool ,*home-volume-name*
+ "usr" "local" "asdf-install")))))
+
+(defvar *private-asdf-install-dirs*
+ #+:sbcl
+ (merge-pathnames (make-pathname :directory '(:relative ".sbcl"))
+ (truename (user-homedir-pathname)))
+ #-:sbcl
+ (cond ((get-env-var "PRIVATE_ASDF_INSTALL_DIR")
+ (directorify (get-env-var "PRIVATE_ASDF_INSTALL_DIR")))
+ (t
+ (merge-pathnames (make-pathname
+ :directory '(:relative ".asdf-install-dir"))
+ (truename (user-homedir-pathname))))))
+
+(defparameter *locations*
+ `((,(merge-pathnames (make-pathname :directory '(:relative "site"))
+ *asdf-install-dirs*)
+ ,(merge-pathnames (make-pathname :directory '(:relative "site-systems"))
+ *asdf-install-dirs*)
+ "System-wide install")
+ (,(merge-pathnames (make-pathname :directory '(:relative "site"))
+ *private-asdf-install-dirs*)
+ ,(merge-pathnames (make-pathname :directory '(:relative "systems"))
+ *private-asdf-install-dirs*)
+ "Personal installation")))
+
+(defvar *tar-extractors*
+ '(extract-using-tar))
+
+(defvar *systems-installed-this-time* nil
+ "Used during installation propagation \(see *propagate-installation*\) to keep track off which systems have been installed during the current call to install.")
+
+(defvar *propagate-installation* nil
+ "If true, then every required system will be re-asdf-installed.")
+
+(defvar *temporary-directory*
+ (pathname-sans-name+type (user-homedir-pathname)))
+
+(defvar *gpg-command* "gpg"
+ "Location of the gpg binary, if for some reason, it does appear in
+ the default path for /bin/sh.")
+
+
More information about the armedbear-cvs
mailing list