On Tue, 23 Mar 2010 14:35:49 +0100, james anderson james.anderson@setf.de wrote:
[ ... continued ]
It was a simple experiment. Define a restricted package and interpret .asd files with a restricted read-eval loop.
For what it's worth, this is what I use in desire, with an obligatory piece of poetry compensating for the inevitable brain damage:
;;;; ;;;; o/~ Below zero, below my need for words o/~ ;;;; o/~ Feel you lifeform, not human. o/~ ;;;; ... ;;;; o/~ Of all the big mistakes I've done o/~ ;;;; o/~ The small ones will remain... o/~ ;;;; (defun invoke-with-safe-reader-context (fn) (let ((*read-eval* nil) (*readtable* (copy-readtable))) (set-dispatch-macro-character ## #. (lambda (stream &optional char sharp) (declare (ignore char sharp)) (let ((*read-suppress* t)) (read stream nil nil t)))) (funcall fn)))
(defmacro with-safe-reader-context (() &body body) `(invoke-with-safe-reader-context (lambda () ,@body)))
(defun map-asd-defsystems (stream fn) (with-safe-reader-context () (flet ((form-defsystem-p (f) (and (consp f) (string= "DEFSYSTEM" (symbol-name (first f))) (or (stringp (second f)) (symbolp (second f)))))) (iter (for pre-read-posn = (file-position stream)) (for form = (handler-case (read stream nil 'das-eof) (serious-condition () ;; seek the offending form (let ((*read-suppress* t)) (file-position stream pre-read-posn) (read stream nil nil))))) (until (eq 'das-eof form)) (when (form-defsystem-p form) (collect (funcall fn form)))))))
(defmacro do-asd-defsystems ((form stream) &body body) `(map-asd-defsystems ,stream (lambda (,form) ,@body)))
(defun normalise-asdf-sysdep (dep) "Given an ASDF system dependency, normalise it by returning the name depended upon as the primary value, and the required version, whenever present as the secondary value." (if (consp dep) (values (second dep) (first dep)) dep))
(defun asdf-system-dependencies (system) "Parse an .asd as if it were declarative." (with-open-file (s (system-definition-pathname system)) (apply #'nconc (do-asd-defsystems (form s) (destructuring-bind (defsystem name &key depends-on &allow-other-keys) form (declare (ignore defsystem)) (when (string-equal name (name system)) (mapcar (compose #'canonicalise-name #'normalise-asdf-sysdep) depends-on)))))))
(defun asdf-hidden-system-names (pathname) "Find out names of ASDF systems hiding in .asd in PATHNAME. A hidden system is a system with a definition residing in a file named differently from that system's name." (let ((primary-system-name (string-upcase (pathname-name pathname)))) (with-open-file (s pathname) (remove nil (do-asd-defsystems (form s) (let ((system-name (string-upcase (string (second form))))) (when (not (string= primary-system-name system-name)) system-name)))))))