Permalink
Browse files

Use PJB's reader; parse dependencies without ASDF.

  • Loading branch information...
1 parent 2e1e4f0 commit bc85ce09e52918b64631664d29ab18d9f789c9aa @orivej committed Dec 3, 2012
Showing with 50 additions and 30 deletions.
  1. +10 −2 package.lisp
  2. +15 −0 quickdist-reader.lisp
  3. +3 −1 quickdist.asd
  4. +22 −27 quickdist.lisp
View
@@ -1,9 +1,17 @@
+(defpackage #:quickdist-reader
+ (:use #:cl)
+ (:shadowing-import-from #:com.informatimago.common-lisp.lisp-reader.reader
+ #:*readtable* #:copy-readtable
+ #:set-dispatch-macro-character
+ #:read
+ #:symbol-in-missing-package-error #:intern-here
+ #:symbol-missing-in-package-error #:make-symbol)
+ (:export #:safe-read))
+
(defpackage #:quickdist
(:use #:cl #:alexandria)
(:import-from #:quicklisp
#:file-size)
- (:import-from #:asdf
- #:load-sysdef)
(:export #:quickdist
#:*distinfo-template*
#:*distinfo-file-template*
View
@@ -0,0 +1,15 @@
+(in-package #:quickdist-reader)
+
+(defvar *safe-readtable*
+ (let ((readtable (copy-readtable *readtable*)))
+ (flet ((read* (stream &rest ignore)
+ (declare (ignore ignore))
+ (safe-read stream nil (values) t)))
+ (set-dispatch-macro-character #\# #\. #'read* readtable))
+ readtable))
+
+(defun safe-read (&optional (stream *standard-input*) (eof-error-p t) eof-value recursive-p)
+ (handler-bind ((symbol-in-missing-package-error (lambda (c) (declare (ignore c)) (invoke-restart 'intern-here)))
+ (symbol-missing-in-package-error (lambda (c) (declare (ignore c)) (invoke-restart 'make-symbol))))
+ (let ((*readtable* *safe-readtable*))
+ (read stream eof-error-p eof-value recursive-p))))
View
@@ -2,7 +2,9 @@
:depends-on (alexandria
cl-fad
external-program
- quicklisp)
+ quicklisp
+ com.informatimago.common-lisp.lisp-reader)
:serial t
:components ((:file "package")
+ (:file "quickdist-reader")
(:file "quickdist")))
View
@@ -79,35 +79,30 @@ system-index-url: {base-url}/{name}/{version}/systems.txt
if (string= "asd" (pathname-type file)) collect file)
#'string< :key #'pathname-name))
-(defvar *safe-readtable*
- (let ((readtable (copy-readtable)))
- (flet ((read* (stream &rest ignore)
- (declare (ignore ignore))
- (read stream nil (values) t)))
- (set-dispatch-macro-character #\# #\. #'read* readtable))
- readtable))
-
-(defun get-systems (path)
- (with-open-file (s path)
- (let* ((package (make-package (symbol-name (gensym "TMPPKG"))))
- (*package* package)
- (*readtable* *safe-readtable*))
+(defun asdf-dependency-name (form)
+ (cond
+ ((and (listp form) (eq :version (first form)))
+ (second form))
+ (t form)))
+
+(defun get-systems (asd-path)
+ (with-open-file (s asd-path)
+ (let* ((package (make-package (symbol-name (gensym "TMPPKG")) '(:cl :asdf)))
+ (*package* package))
(unwind-protect
(sort
- (loop for form = (read s nil)
+ (loop for form = (quickdist-reader:safe-read s nil)
while form
when (and (symbolp (car form))
(equalp "defsystem" (symbol-name (car form))))
- collect (string-downcase (string (cadr form))))
- #'string<)
+ collect (list* (cadr form)
+ (sort (mapcar #'asdf-dependency-name
+ (append (getf form :defsystem-depends-on)
+ (getf form :depends-on)))
+ #'string-lessp)))
+ #'string-lessp :key #'first)
(delete-package package)))))
-(defun system-dependencies (system-designator)
- (sort
- (let ((system (asdf:find-system system-designator)))
- (flatten (rest (assoc 'asdf:load-op (asdf:component-depends-on 'asdf:load-op system)))))
- 'string<))
-
(defun unix-filename (path)
(format nil "~a.~a" (pathname-name path) (pathname-type path)))
@@ -133,11 +128,11 @@ system-index-url: {base-url}/{name}/{version}/systems.txt
project-name project-url (file-size tgz-path) (md5sum tgz-path) (tar-content-sha1 tgz-path) project-prefix
(mapcar #'unix-filename system-files))
(dolist (system-file system-files)
- (asdf::load-sysdef (pathname-name system-file) system-file)
- (dolist (system-name (get-systems system-file))
- (format system-index "~a ~a ~a~{ ~(~a~)~}~%"
- project-name (pathname-name system-file) system-name
- (system-dependencies system-name)))))))))))))
+ (dolist (name-and-dependencies (get-systems system-file))
+ (let ((*print-case* :downcase))
+ (format system-index "~a ~a ~a~{ ~a~}~%"
+ project-name (pathname-name system-file) (first name-and-dependencies)
+ (rest name-and-dependencies))))))))))))))
(defun quickdist (&key name (version :today) base-url projects-dir dists-dir)
(let* ((version (if (not (eq version :today)) version (format-date (get-universal-time))))

0 comments on commit bc85ce0

Please sign in to comment.