[asdf-devel] ANU, or changes which should be backported to ASDF 1.0 [ Re: Enforcing pure *.asd files (2)

[Samium Gromoff]

On Tue, 23 Mar 2010 14:35:49 +0100, james anderson <james.anderson at 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 () , at 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) , at 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)))))))


-- 
regards,
  Samium Gromoff
--
"Actually I made up the term 'object-oriented', and I can tell you I
did not have C++ in mind." - Alan Kay (OOPSLA 1997 Keynote)